OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

CO_BROADCAST for derived types with allocatable components 

From-SVN: r276164
This commit is contained in:
Alessandro Fanfarillo 2019-09-26 13:59:00 -06:00
parent 9ab2f9aed0
commit c78d342520
5 changed files with 260 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View File

@ -1,3 +1,17 @@
2019-09-26 Alessandro Fanfarillo <afanfa@gcc.gnu.org>
* trans-array.c (structure_alloc_comps):
Add new enum item for BCAST_ALLOC_COMP.
New argument for structure_alloc_comp, and new case to handle
recursive components in derived types.
* trans-array.c (gfc_bcast_alloc_comp): New function
used to handleco_broadcast for allocatable components
of derived types.
* trans-array.h: Add gfc_bcast_alloc_comp
* trans-intrinsics.c (conv_co_collective): Add check for
derived type variable and invocation of co_bcast_alloc_comp.
* trans.h: New data structure gfc_co_subroutines_args.
2019-09-25 David Malcolm <dmalcolm@redhat.com>
PR fortran/91426

202
gcc/fortran/trans-array.c
View File

@ -8580,13 +8580,15 @@ gfc_caf_is_dealloc_only (int caf_mode)
enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP,
COPY_ALLOC_COMP, COPY_ONLY_ALLOC_COMP, REASSIGN_CAF_COMP,
ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY};
ALLOCATE_PDT_COMP, DEALLOCATE_PDT_COMP, CHECK_PDT_DUMMY,
BCAST_ALLOC_COMP};
static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree dest, int rank, int purpose, int caf_mode)
tree dest, int rank, int purpose, int caf_mode,
gfc_co_subroutines_args *args)
{
gfc_component *c;
gfc_loopinfo loop;
@ -8672,14 +8674,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
&& !caf_enabled (caf_mode))
{
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest));
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
COPY_ALLOC_COMP, 0);
COPY_ALLOC_COMP, 0, args);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
caf_mode);
caf_mode, args);
gfc_add_expr_to_block (&loopbody, tmp);
@ -8713,13 +8715,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_PDT_COMP, 0);
DEALLOCATE_PDT_COMP, 0, args);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP, 0);
NULLIFY_ALLOC_COMP, 0, args);
gfc_add_expr_to_block (&fnblock, tmp);
}
@ -8741,6 +8743,125 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
switch (purpose)
{
case BCAST_ALLOC_COMP:
tree ubound;
tree cdesc;
stmtblock_t derived_type_block;
gfc_init_block (&tmpblock);
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
/* Shortcut to get the attributes of the component. */
if (c->ts.type == BT_CLASS)
{
attr = &CLASS_DATA (c)->attr;
if (attr->class_pointer)
continue;
}
else
{
attr = &c->attr;
if (attr->pointer)
continue;
}
add_when_allocated = NULL_TREE;
if (cmp_has_alloc_comps
&& !c->attr.pointer && !c->attr.proc_pointer)
{
if (c->ts.type == BT_CLASS)
{
rank = CLASS_DATA (c)->as ? CLASS_DATA (c)->as->rank : 0;
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
caf_mode, args);
}
else
{
rank = c->as ? c->as->rank : 0;
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
caf_mode, args);
}
}
gfc_init_block (&derived_type_block);
if (add_when_allocated)
gfc_add_expr_to_block (&derived_type_block, add_when_allocated);
tmp = gfc_finish_block (&derived_type_block);
gfc_add_expr_to_block (&tmpblock, tmp);
/* Convert the component into a rank 1 descriptor type. */
if (attr->dimension)
{
tmp = gfc_get_element_type (TREE_TYPE (comp));
ubound = gfc_full_array_size (&tmpblock, comp,
c->ts.type == BT_CLASS
? CLASS_DATA (c)->as->rank
: c->as->rank);
}
else
{
tmp = TREE_TYPE (comp);
ubound = build_int_cst (gfc_array_index_type, 1);
}
cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
&ubound, 1,
GFC_ARRAY_ALLOCATABLE, false);
cdesc = gfc_create_var (cdesc, "cdesc");
DECL_ARTIFICIAL (cdesc) = 1;
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
gfc_index_zero_node,
gfc_index_one_node);
gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
gfc_index_zero_node,
gfc_index_one_node);
gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
gfc_index_zero_node, ubound);
if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
else
{
gfc_se se;
gfc_init_se (&se, NULL);
comp = gfc_conv_scalar_to_descriptor (&se, comp,
c->ts.type == BT_CLASS
? CLASS_DATA (c)->attr
: c->attr);
comp = gfc_build_addr_expr (NULL_TREE, comp);
gfc_add_block_to_block (&tmpblock, &se.pre);
}
gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
tree fndecl;
fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr (pvoid_type_node,cdesc),
args->image_index,
null_pointer_node, null_pointer_node,
null_pointer_node);
gfc_add_expr_to_block (&tmpblock, fndecl);
gfc_add_block_to_block (&fnblock, &tmpblock);
break;
case DEALLOCATE_ALLOC_COMP:
gfc_init_block (&tmpblock);
@ -8791,7 +8912,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
caf_mode);
caf_mode, args);
}
else
{
@ -8799,7 +8920,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
caf_mode);
caf_mode, args);
}
}
@ -9075,7 +9196,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose, caf_mode);
rank, purpose, caf_mode, args);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@ -9110,7 +9231,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose, caf_mode
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
args);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
@ -9230,7 +9352,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose,
caf_mode);
caf_mode, args);
}
else
add_when_allocated = NULL_TREE;
@ -9594,7 +9716,7 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
}
@ -9607,9 +9729,47 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode);
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
}
tree
gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
tree image_index, tree stat, tree errmsg,
tree errmsg_len)
{
tree tmp, array;
gfc_se argse;
stmtblock_t block, post_block;
gfc_co_subroutines_args args;
args.image_index = image_index;
args.stat = stat;
args.errmsg = errmsg;
args.errmsg = errmsg_len;
if (rank == 0)
{
gfc_start_block (&block);
gfc_init_block (&post_block);
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, expr);
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
array = argse.expr;
}
else
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr_descriptor (&argse, expr);
array = argse.expr;
}
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
BCAST_ALLOC_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
return tmp;
}
/* Recursively traverse an object of derived type, generating code to
deallocate allocatable components. But do not deallocate coarrays.
@ -9620,7 +9780,7 @@ tree
gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP, 0);
DEALLOCATE_ALLOC_COMP, 0, NULL);
}
@ -9628,7 +9788,7 @@ tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY);
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
}
@ -9640,7 +9800,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
int caf_mode)
{
return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
caf_mode);
caf_mode, NULL);
}
@ -9651,7 +9811,7 @@ tree
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
{
return structure_alloc_comps (der_type, decl, dest, rank,
COPY_ONLY_ALLOC_COMP, 0);
COPY_ONLY_ALLOC_COMP, 0, NULL);
}
@ -9666,7 +9826,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
ALLOCATE_PDT_COMP, 0);
ALLOCATE_PDT_COMP, 0, NULL);
pdt_param_list = old_param_list;
return res;
}
@ -9678,7 +9838,7 @@ tree
gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_PDT_COMP, 0);
DEALLOCATE_PDT_COMP, 0, NULL);
}
@ -9693,7 +9853,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
CHECK_PDT_DUMMY, 0);
CHECK_PDT_DUMMY, 0, NULL);
pdt_param_list = old_param_list;
return res;
}

2
gcc/fortran/trans-array.h
View File

@ -52,6 +52,8 @@ bool gfc_caf_is_dealloc_only (int);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree, tree, tree);
tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);

92
gcc/fortran/trans-intrinsic.c
View File

@ -10786,13 +10786,12 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
}
}
static tree
conv_co_collective (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
tree fndecl, array = NULL_TREE, strlen, image_index, stat, errmsg, errmsg_len;
gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
gfc_start_block (&block);
@ -10857,6 +10856,7 @@ conv_co_collective (gfc_code *code)
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
array = argse.expr;
}
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
@ -10915,46 +10915,64 @@ conv_co_collective (gfc_code *code)
gcc_unreachable ();
}
if (code->resolved_isym->id == GFC_ISYM_CO_SUM
|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
image_index, stat, errmsg, errmsg_len);
else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
stat, errmsg, strlen, errmsg_len);
gfc_symbol *derived = code->ext.actual->expr->ts.type == BT_DERIVED
? code->ext.actual->expr->ts.u.derived : NULL;
if (derived && derived->attr.alloc_comp
&& code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
/* The derived type has the attribute 'alloc_comp'. */
{
tree tmp = gfc_bcast_alloc_comp (derived, code->ext.actual->expr,
code->ext.actual->expr->rank,
image_index, stat, errmsg, errmsg_len);
gfc_add_expr_to_block (&block, tmp);
}
else
{
tree opr, opr_flags;
// FIXME: Handle TS29113's bind(C) strings with descriptor.
int opr_flag_int;
if (gfc_is_proc_ptr_comp (opr_expr))
{
gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
opr_flag_int = sym->attr.dimension
|| (sym->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
}
if (code->resolved_isym->id == GFC_ISYM_CO_SUM
|| code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
image_index, stat, errmsg, errmsg_len);
else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
fndecl = build_call_expr_loc (input_location, fndecl, 6, array,
image_index, stat, errmsg,
strlen, errmsg_len);
else
{
opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !opr_expr->symtree->n.sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
? GFC_CAF_ARG_VALUE : 0;
tree opr, opr_flags;
// FIXME: Handle TS29113's bind(C) strings with descriptor.
int opr_flag_int;
if (gfc_is_proc_ptr_comp (opr_expr))
{
gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
opr_flag_int = sym->attr.dimension
|| (sym->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= sym->formal->sym->attr.value
? GFC_CAF_ARG_VALUE : 0;
}
else
{
opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
? GFC_CAF_BYREF : 0;
opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
&& !opr_expr->symtree->n.sym->attr.is_bind_c
? GFC_CAF_HIDDENLEN : 0;
opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
? GFC_CAF_ARG_VALUE : 0;
}
opr_flags = build_int_cst (integer_type_node, opr_flag_int);
gfc_conv_expr (&argse, opr_expr);
opr = argse.expr;
fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr,
opr_flags, image_index, stat, errmsg,
strlen, errmsg_len);
}
opr_flags = build_int_cst (integer_type_node, opr_flag_int);
gfc_conv_expr (&argse, opr_expr);
opr = argse.expr;
fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
image_index, stat, errmsg, strlen, errmsg_len);
}
gfc_add_expr_to_block (&block, fndecl);

8
gcc/fortran/trans.h
View File

@ -107,6 +107,14 @@ typedef struct gfc_se
}
gfc_se;
typedef struct gfc_co_subroutines_args
{
tree image_index;
tree stat;
tree errmsg;
tree errmsg_len;
}
gfc_co_subroutines_args;
/* Denotes different types of coarray.
Please keep in sync with libgfortran/caf/libcaf.h. */