Gfortran was not compliant with F2018(11.1.5.2), which requires that
coarrays that are allocated within a team block are deallocated immediately
before END TEAM.
This the fourth variant of the patch; the main differences being whether
the code is located on resolve.cc, split between resolve.cc and
trans-stmt.cc or, as here, split between parse.cc, match.cc and st.cc.
The main attraction of the latter scheme is that coarray.cc and
resolve.cc do the main job of preparing the code for translation.
The team context is tracked using a vector of team namespaces, which is
pushed at CHANGE TEAM and popped at END TEAM. The allocate expressions
are stashed in a vector hash_map, keyed on the namespace. The allocate
expressions are stored while the ALLOCATE statments are being matched.
They are then recovered before end in parse_change_team and sent off
for automatic deallocation in st.cc(deallocate_allocated_coarrays.
The use of st.cc for functions generating chunks of code is a pointer
to something that I have been eyeing for a long time, which is to
extract all such functions from class.cc and resolve.cc so that they
can be refactored to use common chunks. This, however, is for another
time!
2026-07-24 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/126205
* gfortran.h: Add prototype for deallocate_allocated_coarrays.
hash_map team_allocated_coarrays, vector team_context_stack and
prototype for get_current_team_context.
* match.cc (gfc_match_allocate): Capture allocate expressions
of allocatable coarrays and stash in team_allocated_coarrays.
* parse.cc (parse_change_team): Push team context. When end is
seen, create the code to deallocate allocated coarrays in this
context, using deallocate_allocated_coarrays.
* st.cc (get_guarded_dealloc): Generate code to produce
IF (ALLOCATED (expr)) DEALLOCATE (expr).
(deallocate_allocated_coarrays): Modify the final array ref of
the allocate expressions and call get_guarded_dealloc.
gcc/testsuite/
PR fortran/126205
* gfortran.dg/coarray/team_allocated_coarrays.f90: New test.
/* st.cc */
extern gfc_code new_st;
-
void gfc_clear_new_st (void);
gfc_code *gfc_get_code (gfc_exec_op);
gfc_code *gfc_append_code (gfc_code *, gfc_code *);
void gfc_free_statement (gfc_code *);
void gfc_free_statements (gfc_code *);
void gfc_free_association_list (gfc_association_list *);
+void deallocate_allocated_coarrays (vec<gfc_expr *> *);
/* resolve.cc */
void gfc_resolve_symbol (gfc_symbol *);
gfc_namespace* gfc_build_block_ns (gfc_namespace *);
gfc_statement match_omp_directive (void);
bool is_omp_declarative_stmt (gfc_statement);
+extern hash_map<gfc_namespace *, vec<gfc_expr *>> team_allocated_coarrays;
+extern vec<gfc_namespace *> team_context_stack;
+gfc_namespace *get_current_team_context (void);
/* dependency.cc */
int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
goto cleanup;
}
+ /* F2018(11.1.5.2): Track coarrays allocated in team blocks. */
+ gfc_namespace *team_ns = get_current_team_context ();
+ bool codim = tail->expr->symtree->n.sym->attr.codimension
+ || (tail->expr->symtree->n.sym->as
+ && tail->expr->symtree->n.sym->as->corank);
+ for (gfc_ref *r = tail->expr->ref; r; r = r->next)
+ if (r->type == REF_COMPONENT && r->u.c.component)
+ codim = r->u.c.component->attr.codimension
+ || (r->u.c.component->as && r->u.c.component->as->corank);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && team_ns && codim)
+ {
+ gfc_expr *e = gfc_copy_expr (tail->expr);
+ vec<gfc_expr *> &allocated = team_allocated_coarrays.get_or_insert (team_ns);
+ allocated.safe_push (e);
+ }
+
if (gfc_match_char (',') != MATCH_YES)
break;
pop_state ();
}
+
+/* F2018(11.1.5.2): Track coarrays allocated within CHANGE TEAM blocks.
+ Map from team namespace to vector of allocated coarray symbols. */
+hash_map<gfc_namespace *, vec<gfc_expr *>> team_allocated_coarrays;
+
+/* Stack to track current CHANGE TEAM context. */
+vec<gfc_namespace *> team_context_stack;
+
+gfc_namespace *
+get_current_team_context (void)
+{
+ return team_context_stack.is_empty () ? NULL : team_context_stack.last ();
+}
+
+
static void
parse_change_team (void)
{
gfc_namespace *my_ns;
gfc_state_data s;
gfc_statement st;
+ vec<gfc_expr *> *team_allocs;
gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
accept_statement (ST_CHANGE_TEAM);
push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
+ /* Push team context for tracking coarrays allocated in a team block. */
+ team_context_stack.safe_push (gfc_current_ns);
+
loop:
st = parse_executable (ST_NONE);
switch (st)
case_end:
accept_statement (st);
my_ns->code = gfc_state_stack->head;
+ /* F2018(11.1.5.2): Deallocate coarray expressions allocated in this
+ team block, */
+ team_allocs = team_allocated_coarrays.get (gfc_current_ns);
+ if (team_allocs)
+ deallocate_allocated_coarrays (team_allocs);
+ /* Pop team context. */
+ team_context_stack.pop ();
break;
default:
gfc_free_association_list (assoc->next);
free (assoc);
}
+
+
+/* Function to generate IF (ALLOCATED(expr)) DEALLOCATE(expr) */
+
+static gfc_code *
+get_guarded_dealloc (gfc_namespace *ns, gfc_expr *expr)
+{
+ gfc_code *dealloc = gfc_get_code (EXEC_IF);
+ dealloc->block = gfc_get_code (EXEC_IF);
+#define ALLOCATED dealloc->block->expr1
+ ALLOCATED = gfc_get_expr ();
+ ALLOCATED->expr_type = EXPR_FUNCTION;
+ ALLOCATED->where = gfc_current_locus;
+ gfc_find_sym_tree ("allocated", ns, 1, &ALLOCATED->symtree);
+ if (!ALLOCATED->symtree)
+ {
+ gfc_get_sym_tree ("allocated", ns, &ALLOCATED->symtree, false);
+ gfc_commit_symbol (ALLOCATED->symtree->n.sym);
+ }
+ ALLOCATED->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ ALLOCATED->symtree->n.sym->attr.intrinsic = 1;
+ ALLOCATED->symtree->n.sym->result = ALLOCATED->symtree->n.sym;
+ ALLOCATED->ts.type = BT_LOGICAL;
+ ALLOCATED->ts.kind = gfc_default_logical_kind;
+ ALLOCATED->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_ALLOCATED);
+ ALLOCATED->value.function.actual = gfc_get_actual_arglist ();
+ ALLOCATED->value.function.actual->expr = gfc_copy_expr (expr);
+#undef ALLOCATED
+ dealloc->block->next = gfc_get_code (EXEC_DEALLOCATE);
+ dealloc->block->next->ext.alloc.list = gfc_get_alloc ();
+ dealloc->block->next->ext.alloc.list->expr = gfc_copy_expr (expr);
+ return dealloc;
+}
+
+
+/* F2018(11.1.5.2): Insert code to deallocate coarrays, allocated within a team
+ block. This uses the previous function to effect a guarded deallocation of
+ allocated coarray expressions. These are gathered in gfc_match_allocate and
+ stashed in team_allocs. */
+
+void
+deallocate_allocated_coarrays (vec<gfc_expr *> *team_allocs)
+{
+ gfc_code *dealloc, *last_stmt;
+ gfc_ref *ref, *aref = NULL;
+ int i;
+
+ for (gfc_expr *e : *team_allocs)
+ {
+ if (!e)
+ continue;
+
+ /* Get the last array_ref right. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY)
+ aref = ref;
+
+ if (aref->u.ar.as->rank)
+ {
+ aref->u.ar.type = AR_FULL;
+ aref->u.ar.dimen = aref->u.ar.as->rank;
+ for (i = 0; i < aref->u.ar.dimen; i++)
+ {
+ aref->u.ar.dimen_type[i] = DIMEN_RANGE;
+
+ if (aref->u.ar.start[i]) gfc_free_expr (aref->u.ar.start[i]);
+ if (aref->u.ar.end[i]) gfc_free_expr (aref->u.ar.end[i]);
+ if (aref->u.ar.stride[i]) gfc_free_expr (aref->u.ar.stride[i]);
+ aref->u.ar.start[i] = aref->u.ar.end[i] = aref->u.ar.stride[i] = NULL;
+ }
+ }
+
+ for (i = aref->u.ar.as->rank;
+ i < aref->u.ar.as->rank + aref->u.ar.as->corank; i++)
+ aref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+
+ /* Insert the deallocation code before the END TEAM statement. */
+ last_stmt = gfc_current_ns->code;
+ while (last_stmt)
+ {
+ last_stmt = last_stmt->next;
+ if (last_stmt->next->op == EXEC_END_TEAM || !last_stmt->next)
+ {
+ dealloc = get_guarded_dealloc (gfc_current_ns, e);
+ if (dealloc)
+ {
+ dealloc->next = last_stmt->next;
+ last_stmt->next = dealloc;
+ break;
+ }
+ }
+ }
+ gfc_free_expr (e);
+ e = NULL;
+ }
+}
--- /dev/null
+! { dg-do run }
+!
+! F2018(11.1.5.2): Test auto-deallocation of allocatable coarrays that are
+! allocated within a team block.
+!
+program test_nested_teams
+ use iso_fortran_env, only: team_type
+ implicit none
+ type(team_type) :: team1, team2
+ integer, allocatable :: a[:]
+ integer, allocatable :: b[:]
+ integer, allocatable :: outer[:]
+ integer, allocatable :: inner(:)[:] ! Rank and corank
+ logical :: image1
+ integer :: me
+
+ type :: mytype
+ integer, allocatable :: i[:]
+ end type
+ type(mytype) :: dt_a, dt_b, dt_outer, dt_inner
+
+ image1 = this_image () == 1
+ me = this_image ()
+
+ ! Test 1: Simple allocation in single team block
+ form team(1, team1)
+ change team(team1)
+ allocate(a[*])
+ a = 1
+ allocate(dt_a%i[*], source = me)
+ end team
+ if (image1 .and. allocated(a)) stop 1
+ if (image1 .and. allocated(dt_a%i)) stop 2
+
+ ! Test 2: Multiple allocations in single team block
+ form team(1, team1)
+ change team(team1)
+ allocate(a[*], b[*])
+ a = 1
+ b = 2
+ allocate(dt_a%i[*], dt_b%i[*], source = me)
+ end team
+ if (image1 .and. allocated(a)) stop 3
+ if (image1 .and. allocated(b)) stop 4
+ if (image1 .and. allocated(dt_a%i)) stop 5
+ if (image1 .and. allocated(dt_b%i)) stop 6
+
+ ! Test 3: Nested team blocks - allocation in outer team only
+ form team(1, team1)
+ change team(team1)
+ allocate(outer[*])
+ allocate(dt_outer%i[*], source = me)
+ outer = 10
+
+ ! Nested team with no allocations
+ form team(1, team2)
+ change team(team2)
+ end team
+
+ ! Make sure that auto-deallocation occurs in right context
+ if (image1 .and. .not.allocated(outer)) stop 7
+ if (image1 .and. .not.allocated(dt_outer%i)) stop 8
+
+ end team
+ if (image1 .and. allocated(outer)) stop 9
+ if (image1 .and. allocated(dt_outer%i)) stop 10
+
+ ! Test 4: Nested team blocks - allocation in inner team only
+ form team(1, team1)
+ change team(team1)
+
+ form team(1, team2)
+ change team(team2)
+ allocate(inner(4)[*])
+ inner = 20
+ allocate(dt_inner%i[*])
+ end team
+
+ if (image1 .and. allocated(inner)) stop 11
+ if (image1 .and. allocated(dt_inner%i)) stop 12
+ end team
+
+ ! Test 5: Nested team blocks - allocations in both levels
+ form team(1, team1)
+ change team(team1)
+ allocate(outer[*])
+ outer = 30
+ allocate(dt_outer%i[*], source = me)
+
+ form team(1, team2)
+ change team(team2)
+ allocate(inner(2)[*])
+ inner = 40
+ allocate(dt_inner%i[*], source = me)
+ end team
+
+ if (image1 .and. allocated(inner)) stop 13
+ if (image1 .and. allocated(dt_inner%i)) stop 14
+
+ end team
+ if (image1 .and. allocated(outer)) stop 15
+ if (image1 .and. allocated(dt_outer%i)) stop 16
+
+end program test_nested_teams
projects / thirdparty / gcc.git / commitdiff
