https://gcc.gnu.org/g:fcfd9dd65b9fd34414b26c160847b134dd317707
commit r16-9513-gfcfd9dd65b9fd34414b26c160847b134dd317707 Author: Paul Thomas <[email protected]> Date: Fri Jul 24 15:05:46 2026 +0100 Fortran: Auto deallocate coarrays, allocated in team blocks [PR126205] 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 <[email protected]> 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. (cherry picked from commit 75be60856749d85ef29358e6ab4f3c48c128589c) Diff: --- gcc/fortran/gfortran.h | 5 +- gcc/fortran/match.cc | 17 ++++ gcc/fortran/parse.cc | 26 ++++++ gcc/fortran/st.cc | 97 +++++++++++++++++++ .../coarray/team_allocated_coarrays.f90 | 104 +++++++++++++++++++++ 5 files changed, 248 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b0ce54e1c210..e4a368bb58fa 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4052,13 +4052,13 @@ bool has_parameterized_comps (gfc_symbol *); /* 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 *); @@ -4234,6 +4234,9 @@ void gfc_global_used (gfc_gsymbol *, locus *); 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); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 07555536051f..da7a6e78958a 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5433,6 +5433,23 @@ gfc_match_allocate (void) 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; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 82cd85851c8d..7c0119938fe7 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5526,12 +5526,28 @@ loop: 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"); @@ -5549,6 +5565,9 @@ parse_change_team (void) 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) @@ -5559,6 +5578,13 @@ loop: 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: diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index ce4fcad884f5..04c3cdd4f61b 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -366,3 +366,100 @@ gfc_free_association_list (gfc_association_list* assoc) 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; + } +} diff --git a/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90 b/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90 new file mode 100644 index 000000000000..4ecee7bbff48 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90 @@ -0,0 +1,104 @@ +! { 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
