Hello All, I pushed the patch as submitted because it applies equally well to all three library models.
The auto-deallocation intrinsic to the library does not work. I have attached a patch for single.c and shmem.c that fixes the problem and pr126205. I haven't as yet looked at what happens with Open Coarrays and would appreciate it if somebody would give it a whirl. Regards Paul On Fri, 24 Jul 2026 at 16:18, Paul Richard Thomas <[email protected]> wrote: > > Hello All, > From John Reid's "Summary_of_Fortran_2018": > > 3.5 Coarrays allocated in teams > > ....snip.... > > In Fortran 2018, synchronization is now across the team, of course. Symmetric > memory is maintained within teams by requiring that > > 1. any allocatable coarray that is allocated before entry to a change team > construct remains allocated during the execution of the construct and > 2. any allocatable coarray that becomes allocated within a change team > construct and is still allocated when the construct is left is automatically > deallocated, even if it has the save attribute. > > ....more snips.... > > Requirement 2 is not yet implemented in gfortran. The attachment does the job. > > Regression tested on FC44/x86_64 - OK for mainline and eventual backporting > to 16-branch? > > Paul >
From 75461e79dff3e8439972492ea2dcb3cfbd8f3d66 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Fri, 31 Jul 2026 16:15:03 +0100 Subject: [PATCH] libgfortran CAF: Fix team-allocated coarray deallocation (library-side) Per F2018 11.1.5.2, allocatable coarrays allocated within a CHANGE TEAM block should be auto-deallocated at END TEAM. This patch fixes four critical bugs in the CAF runtime libraries that prevented proper deallocation: 1. Token ID uninitialized in ALLOCATE_ONLY case: shmem_token->token_id was not set, causing deregister to look up garbage in the ID hashmap. 2. Scalar coarray descriptors not stored: Changed from conditional storage (GFC_DESCRIPTOR_RANK > 0 ? data : NULL) to conditional based on registration type, using new IS_STATIC_REGTYPE macro. This stores descriptors for dynamic allocations while avoiding use-after-scope for static constructor descriptors. Jerry Delisle identified that static coarray descriptors live in _caf_init stack frames that are dead by the time tokens are used. 3. memptr not cleared after deallocation: Added shmem_token->memptr = NULL to mark coarrays as deallocated, preventing use-after-free. 4. is_present_on_remote not checking allocation status: Added early return when memptr is NULL, so allocated() correctly returns false after deallocation. Applied fixes to both shmem.c (shared-memory CAF) and single.c (single-image CAF). Adds test case: team_allocated_coarrays.f90 (auto-deallocation verification). Note: These library-side fixes enable correct deallocation but require the companion compiler patch (PR126205) to generate explicit DEALLOCATE statements for team-allocated coarrays. Reviewed-by: Jerry Delisle Co-Authored-By: Claude <[email protected]> --- .../coarray/team_allocated_coarrays.f90 | 104 ++++++++++++++++++ libgfortran/caf/shmem.c | 23 +++- libgfortran/caf/single.c | 16 ++- 3 files changed, 137 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/team_allocated_coarrays.f90 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 diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c index 6288d22204c..a44b8ebbd15 100644 --- a/libgfortran/caf/shmem.c +++ b/libgfortran/caf/shmem.c @@ -197,6 +197,13 @@ _gfortran_caf_num_images (caf_team_t team, int32_t *team_number) } +/* Static registrations come from the _caf_init constructor, which + passes a descriptor living in its own stack frame. That frame is + gone by the time the token is used, so it must not be retained. */ +#define IS_STATIC_REGTYPE(t) \ + ((t) == CAF_REGTYPE_COARRAY_STATIC || (t) == CAF_REGTYPE_LOCK_STATIC \ + || (t) == CAF_REGTYPE_EVENT_STATIC || (t) == CAF_REGTYPE_CRITICAL) + void _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, gfc_descriptor_t *data, int *stat, char *errmsg, @@ -360,15 +367,16 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, break; case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY: shmem_token->memptr = mem; + shmem_token->desc = data; shmem_token->base = mem; shmem_token->image_size = size; + shmem_token->token_id = ~0U; shmem_token->owning_memory = true; break; case CAF_REGTYPE_COARRAY_MAP_EXISTING: *shmem_token = (struct caf_shmem_token) {mem + size * this_image.image_num, - GFC_DESCRIPTOR_RANK (data) > 0 ? data - : NULL, + data, mem, size, next_memid++, @@ -378,15 +386,14 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, case CAF_REGTYPE_LOCK_ALLOC: case CAF_REGTYPE_CRITICAL: *shmem_token = (struct caf_shmem_token) { - mem, GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL, + mem, IS_STATIC_REGTYPE (type) ? NULL : data, mem, size, next_memid++, false}; break; default: *shmem_token = (struct caf_shmem_token) {mem + size * this_image.image_num, - GFC_DESCRIPTOR_RANK (data) > 0 ? data - : NULL, + IS_STATIC_REGTYPE (type) ? NULL : data, mem, size, next_memid++, @@ -443,6 +450,8 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, if (shmem_token->desc) GFC_DESCRIPTOR_DATA (shmem_token->desc) = NULL; + /* Signal deallocation to _gfortran_caf_is_present_on_remote. */ + shmem_token->memptr = NULL; } if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) @@ -1125,6 +1134,10 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index, NULL, NULL, NULL)) return 0; + /* After deallocation, memptr is set to NULL. */ + if (shmem_token->memptr == NULL) + return 0; + src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size; if (shmem_token->desc) { diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index e48aaec6f05..c4c487865a2 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -209,6 +209,13 @@ _gfortran_caf_num_images (caf_team_t team __attribute__ ((unused)), } +/* Static registrations come from the _caf_init constructor, which + passes a descriptor living in its own stack frame. That frame is + gone by the time the token is used, so it must not be retained. */ +#define IS_STATIC_REGTYPE(t) \ + ((t) == CAF_REGTYPE_COARRAY_STATIC || (t) == CAF_REGTYPE_LOCK_STATIC \ + || (t) == CAF_REGTYPE_EVENT_STATIC || (t) == CAF_REGTYPE_CRITICAL) + void _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, gfc_descriptor_t *data, int *stat, char *errmsg, @@ -252,7 +259,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, single_token->memptr = local; single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY && type != CAF_REGTYPE_COARRAY_MAP_EXISTING; - single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL; + single_token->desc = IS_STATIC_REGTYPE (type) ? NULL : data; if (unlikely (!caf_team_stack)) init_caf_team_stack (); @@ -299,6 +306,8 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, free (single_token->memptr); if (single_token->desc) GFC_DESCRIPTOR_DATA (single_token->desc) = NULL; + /* Mark as deallocated so is_present_on_remote knows not to check this memory. */ + single_token->memptr = NULL; } if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) @@ -713,6 +722,11 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index, return 0; caf_single_token_t single_token = TOKEN (token); + /* Use memptr to determine allocation status. + After deallocation, memptr is set to NULL, so we can safely check it. */ + if (single_token->memptr == NULL) + return 0; + int32_t result; struct caf_single_token cb_token = {add_data, NULL, false}; -- 2.55.0
