Skip to content

Commit b81747c

Browse files
author
Damian Rouson
authored
Merge pull request #24 from afanfa/co_broadcast_alloc_comp
Patch applied
2 parents 1b3146f + 930b421 commit b81747c

File tree

4 files changed

+249
-58
lines changed

4 files changed

+249
-58
lines changed

‎gcc/fortran/trans-array.c‎

Lines changed: 184 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -8302,13 +8302,15 @@ gfc_caf_is_dealloc_only (int caf_mode)
83028302

83038303
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
83048304
COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
8305-
ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
8305+
ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
8306+
BCAST_ALLOC_COMP};
83068307

83078308
static gfc_actual_arglist *pdt_param_list;
83088309

83098310
static tree
83108311
structure_alloc_comps (gfc_symbol * der_type, tree decl,
8311-
tree dest, int rank, int purpose, int caf_mode)
8312+
tree dest, int rank, int purpose, int caf_mode,
8313+
gfc_co_subroutines_args *args)
83128314
{
83138315
gfc_component *c;
83148316
gfc_loopinfo loop;
@@ -8394,14 +8396,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
83948396
&& !caf_enabled (caf_mode))
83958397
{
83968398
tmp = build_fold_indirect_ref_loc (input_location,
8397-
gfc_conv_array_data (dest));
8399+
gfc_conv_array_data (dest));
83988400
dref = gfc_build_array_ref (tmp, index, NULL);
83998401
tmp = structure_alloc_comps (der_type, vref, dref, rank,
8400-
COPY_ALLOC_COMP, 0);
8402+
COPY_ALLOC_COMP, 0, args);
84018403
}
84028404
else
84038405
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
8404-
caf_mode);
8406+
caf_mode, args);
84058407

84068408
gfc_add_expr_to_block (&loopbody, tmp);
84078409

@@ -8435,13 +8437,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
84358437
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
84368438
{
84378439
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8438-
DEALLOCATE_PDT_COMP, 0);
8440+
DEALLOCATE_PDT_COMP, 0, args);
84398441
gfc_add_expr_to_block (&fnblock, tmp);
84408442
}
84418443
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
84428444
{
84438445
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
8444-
NULLIFY_ALLOC_COMP, 0);
8446+
NULLIFY_ALLOC_COMP, 0, args);
84458447
gfc_add_expr_to_block (&fnblock, tmp);
84468448
}
84478449

@@ -8463,6 +8465,128 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
84638465

84648466
switch (purpose)
84658467
{
8468+
8469+
case BCAST_ALLOC_COMP:
8470+
8471+
tree ubound;
8472+
tree cdesc;
8473+
stmtblock_t derived_type_block;
8474+
8475+
gfc_init_block (&tmpblock);
8476+
8477+
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
8478+
decl, cdecl, NULL_TREE);
8479+
8480+
/* Shortcut to get the attributes of the component. */
8481+
if (c->ts.type == BT_CLASS)
8482+
{
8483+
attr = &CLASS_DATA (c)->attr;
8484+
if (attr->class_pointer)
8485+
continue;
8486+
}
8487+
else
8488+
{
8489+
attr = &c->attr;
8490+
if (attr->pointer)
8491+
continue;
8492+
}
8493+
8494+
add_when_allocated = NULL_TREE;
8495+
if (cmp_has_alloc_comps
8496+
&& !c->attr.pointer && !c->attr.proc_pointer)
8497+
{
8498+
/* Add checked deallocation of the components. This code is
8499+
obviously added because the finalizer is not trusted to free
8500+
all memory. */
8501+
if (c->ts.type == BT_CLASS)
8502+
{
8503+
rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
8504+
add_when_allocated
8505+
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
8506+
comp, NULL_TREE, rank, purpose,
8507+
caf_mode, args);
8508+
}
8509+
else
8510+
{
8511+
rank = c->as ? c->as->rank : 0;
8512+
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
8513+
comp, NULL_TREE,
8514+
rank, purpose,
8515+
caf_mode, args);
8516+
}
8517+
}
8518+
8519+
gfc_init_block (&derived_type_block);
8520+
if (add_when_allocated)
8521+
gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
8522+
tmp = gfc_finish_block (&derived_type_block);
8523+
gfc_add_expr_to_block (&tmpblock, tmp);
8524+
8525+
/* Convert the component into a rank 1 descriptor type. */
8526+
if (attr->dimension)
8527+
{
8528+
tmp = gfc_get_element_type (TREE_TYPE (comp));
8529+
ubound = gfc_full_array_size (&tmpblock, comp,
8530+
c->ts.type == BT_CLASS
8531+
? CLASS_DATA (c)->as->rank
8532+
: c->as->rank);
8533+
}
8534+
else
8535+
{
8536+
tmp = TREE_TYPE (comp);
8537+
ubound = build_int_cst (gfc_array_index_type, 1);
8538+
}
8539+
8540+
cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
8541+
&ubound, 1,
8542+
GFC_ARRAY_ALLOCATABLE, false);
8543+
8544+
cdesc = gfc_create_var (cdesc, "cdesc");
8545+
DECL_ARTIFICIAL (cdesc) = 1;
8546+
8547+
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
8548+
gfc_get_dtype_rank_type (1, tmp));
8549+
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
8550+
gfc_index_zero_node,
8551+
gfc_index_one_node);
8552+
gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
8553+
gfc_index_zero_node,
8554+
gfc_index_one_node);
8555+
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
8556+
gfc_index_zero_node, ubound);
8557+
8558+
if (attr->dimension)
8559+
comp = gfc_conv_descriptor_data_get (comp);
8560+
else
8561+
{
8562+
gfc_se se;
8563+
8564+
gfc_init_se (&se, NULL);
8565+
8566+
comp = gfc_conv_scalar_to_descriptor (&se, comp,
8567+
c->ts.type == BT_CLASS
8568+
? CLASS_DATA (c)->attr
8569+
: c->attr);
8570+
comp = gfc_build_addr_expr (NULL_TREE, comp);
8571+
gfc_add_block_to_block (&tmpblock, &se.pre);
8572+
}
8573+
8574+
gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
8575+
8576+
tree fndecl;
8577+
8578+
fndecl = build_call_expr_loc (input_location,
8579+
gfor_fndecl_co_broadcast, 5,
8580+
gfc_build_addr_expr (pvoid_type_node,cdesc),
8581+
args->image_index,
8582+
null_pointer_node, null_pointer_node,
8583+
null_pointer_node);
8584+
8585+
gfc_add_expr_to_block (&tmpblock, fndecl);
8586+
gfc_add_block_to_block (&fnblock, &tmpblock);
8587+
8588+
break;
8589+
84668590
case DEALLOCATE_ALLOC_COMP:
84678591

84688592
gfc_init_block (&tmpblock);
@@ -8513,15 +8637,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
85138637
add_when_allocated
85148638
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
85158639
comp, NULL_TREE, rank, purpose,
8516-
caf_mode);
8640+
caf_mode, args);
85178641
}
85188642
else
85198643
{
85208644
rank = c->as ? c->as->rank : 0;
85218645
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
85228646
comp, NULL_TREE,
85238647
rank, purpose,
8524-
caf_mode);
8648+
caf_mode, args);
85258649
}
85268650
}
85278651

@@ -8797,7 +8921,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
87978921
decl, cdecl, NULL_TREE);
87988922
rank = c->as ? c->as->rank : 0;
87998923
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
8800-
rank, purpose, caf_mode);
8924+
rank, purpose, caf_mode, args);
88018925
gfc_add_expr_to_block (&fnblock, tmp);
88028926
}
88038927
break;
@@ -8832,7 +8956,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
88328956
{
88338957
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
88348958
rank, purpose, caf_mode
8835-
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
8959+
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
8960+
args);
88368961
gfc_add_expr_to_block (&fnblock, tmp);
88378962
}
88388963
}
@@ -8952,7 +9077,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
89529077
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
89539078
comp, dcmp,
89549079
rank, purpose,
8955-
caf_mode);
9080+
caf_mode, args);
89569081
}
89579082
else
89589083
add_when_allocated = NULL_TREE;
@@ -9316,7 +9441,7 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
93169441
{
93179442
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
93189443
NULLIFY_ALLOC_COMP,
9319-
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
9444+
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
93209445
}
93219446

93229447

@@ -9329,9 +9454,47 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
93299454
{
93309455
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
93319456
DEALLOCATE_ALLOC_COMP,
9332-
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
9457+
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
93339458
}
93349459

9460+
tree
9461+
gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
9462+
tree image_index, tree stat, tree errmsg,
9463+
tree errmsg_len)
9464+
{
9465+
tree tmp, array;
9466+
gfc_se argse;
9467+
stmtblock_t block, post_block;
9468+
gfc_co_subroutines_args args;
9469+
9470+
args.image_index = image_index;
9471+
args.stat = stat;
9472+
args.errmsg = errmsg;
9473+
args.errmsg = errmsg_len;
9474+
9475+
if (rank == 0)
9476+
{
9477+
gfc_start_block (&block);
9478+
gfc_init_block (&post_block);
9479+
gfc_init_se (&argse, NULL);
9480+
gfc_conv_expr (&argse, expr);
9481+
gfc_add_block_to_block (&block, &argse.pre);
9482+
gfc_add_block_to_block (&post_block, &argse.post);
9483+
array = argse.expr;
9484+
}
9485+
else
9486+
{
9487+
gfc_init_se (&argse, NULL);
9488+
argse.want_pointer = 1;
9489+
gfc_conv_expr_descriptor (&argse, expr);
9490+
array = argse.expr;
9491+
}
9492+
9493+
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
9494+
BCAST_ALLOC_COMP,
9495+
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
9496+
return tmp;
9497+
}
93359498

93369499
/* Recursively traverse an object of derived type, generating code to
93379500
deallocate allocatable components. But do not deallocate coarrays.
@@ -9342,15 +9505,15 @@ tree
93429505
gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
93439506
{
93449507
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9345-
DEALLOCATE_ALLOC_COMP, 0);
9508+
DEALLOCATE_ALLOC_COMP, 0, NULL);
93469509
}
93479510

93489511

93499512
tree
93509513
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
93519514
{
93529515
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
9353-
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
9516+
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
93549517
}
93559518

93569519

@@ -9362,7 +9525,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
93629525
int caf_mode)
93639526
{
93649527
return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
9365-
caf_mode);
9528+
caf_mode, NULL);
93669529
}
93679530

93689531

@@ -9373,7 +9536,7 @@ tree
93739536
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
93749537
{
93759538
return structure_alloc_comps (der_type, decl, dest, rank,
9376-
COPY_ONLY_ALLOC_COMP, 0);
9539+
COPY_ONLY_ALLOC_COMP, 0, NULL);
93779540
}
93789541

93799542

@@ -9388,7 +9551,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
93889551
gfc_actual_arglist *old_param_list = pdt_param_list;
93899552
pdt_param_list = param_list;
93909553
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9391-
ALLOCATE_PDT_COMP, 0);
9554+
ALLOCATE_PDT_COMP, 0, NULL);
93929555
pdt_param_list = old_param_list;
93939556
return res;
93949557
}
@@ -9400,7 +9563,7 @@ tree
94009563
gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
94019564
{
94029565
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9403-
DEALLOCATE_PDT_COMP, 0);
9566+
DEALLOCATE_PDT_COMP, 0, NULL);
94049567
}
94059568

94069569

@@ -9415,7 +9578,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
94159578
gfc_actual_arglist *old_param_list = pdt_param_list;
94169579
pdt_param_list = param_list;
94179580
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
9418-
CHECK_PDT_DUMMY, 0);
9581+
CHECK_PDT_DUMMY, 0, NULL);
94199582
pdt_param_list = old_param_list;
94209583
return res;
94219584
}

‎gcc/fortran/trans-array.h‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,8 @@ bool gfc_caf_is_dealloc_only (int);
5252
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
5353

5454
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
55+
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
56+
tree, tree, tree);
5557
tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
5658
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
5759

0 commit comments

Comments
 (0)