Re: [Patch, fortran] PR126205 - A coarray allocated in a team is not being automatically deallocated

Paul Richard Thomas <[email protected]>
Newsgroups gmane.comp.gcc.patches,gmane.comp.gcc.fortran
Message-ID <CAGkQGiJKuvUo9af_Q63fpxL=JTNuGzz+eXmL9Sc1gW2524TAKA@mail.gmail.com> 
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
>
library.patch (text/x-patch, 10 KB) 
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
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.