From: Paul Thomas Date: Fri, 24 Jul 2026 14:05:46 +0000 (+0100) Subject: Fortran: Auto deallocate coarrays, allocated in team blocks [PR126205] X-Git-Url: http://git.ipfire.org/gitweb/index.cgi?a=commitdiff_plain;p=thirdparty%2Fgcc.git 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 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. --- diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a5b2e035c84..807756d6a17 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4179,13 +4179,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 *); /* resolve.cc */ void gfc_resolve_symbol (gfc_symbol *); @@ -4362,6 +4362,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> team_allocated_coarrays; +extern vec 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 b09d348e6b5..d61757046d2 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5443,6 +5443,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 &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 eeb98865513..c5d79bf2fd0 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5582,12 +5582,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> team_allocated_coarrays; + +/* Stack to track current CHANGE TEAM context. */ +vec 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 *team_allocs; gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C"); @@ -5605,6 +5621,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) @@ -5615,6 +5634,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 4c7e274b72a..b9c15b2d0f8 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -369,3 +369,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 *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 00000000000..4ecee7bbff4 --- /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