This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
Dear all, please find in attachment a preliminary patch that adds support to co_broadcast for allocatable components of derived types. The patch is currently ignoring the stat and errmsg arguments, mostly because I am not sure how to handle them properly. I have created a new data structure called used to pass those argument to the preexisting structure_alloc_comps. Suggestions on how to handle them are more than welcome :-) The patch builds correctly on x86_64 and it has been tested with OpenCoarrays and the following test cases: https://github.com/sourceryinstitute/OpenCoarrays/blob/co_broadcast-derived-type/src/tests/unit/collectives/co_broadcast_allocatable_components.f90 https://github.com/sourceryinstitute/OpenCoarrays/blob/co_broadcast-derived-type/src/tests/unit/collectives/co_broadcast_allocatable_components_array.f90 Regards,
commit b9458ff4414615263ed92d8965c93fd0a953f4a9
Author: Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
Date: Thu Aug 22 10:50:17 2019 -0600
Co_broadcast derived types with allocatable components
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8d74e588dd..005646f1359 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8571,13 +8571,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;
@@ -8663,14 +8665,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);
@@ -8704,13 +8706,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);
}
@@ -8732,6 +8734,128 @@ 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)
+ {
+ /* Add checked deallocation of the components. This code is
+ obviously added because the finalizer is not trusted to free
+ all memory. */
+ 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);
@@ -8782,7 +8906,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
{
@@ -8790,7 +8914,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);
}
}
@@ -9066,7 +9190,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;
@@ -9101,7 +9225,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);
}
}
@@ -9221,7 +9346,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;
@@ -9585,7 +9710,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);
}
@@ -9598,9 +9723,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.
@@ -9611,7 +9774,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);
}
@@ -9619,7 +9782,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);
}
@@ -9631,7 +9794,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);
}
@@ -9642,7 +9805,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);
}
@@ -9657,7 +9820,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;
}
@@ -9669,7 +9832,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);
}
@@ -9684,7 +9847,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;
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8c2d51838d4..5a7eee7e305 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 26ea624101d..c2e0533393a 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -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);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 8082b414df1..84793dc1df0 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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. */
Attachment:
Changelog_co_broadcast
Description: Binary data
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |