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
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 (, 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 (, 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 (, 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 ();
+
+ 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 = _DATA (c)->attr;
+ if (attr->class_pointer)
+ continue;
+ }
+ else
+ {
+ attr = >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 (_type_block);
+ if (add_when_allocated)
+ gfc_add_expr_to_block (_type_block, add_when_allocated);
+ tmp = gfc_finish_block (_type_block);
+ gfc_add_expr_to_block (, 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 (, comp,
+ c->ts.type == BT_CLASS
+ ? CLASS_DATA (c)->as->rank
+ : c->as->rank);
+ }
+ else
+ {
+
