See the attached patch. This is the second of the two patches making things a
bit mor reliable.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127751] caf_shmem: report a full table of coarray ids
When ALLOCATE of a coarray needed a larger table of coarray ids and the
shared memory pool could not hold it, the image error terminated while
holding the allocator lock, so the other images hung. The table is now
left unchanged and the failure is reported through STAT= and ERRMSG=.
Old tables were also freed with their number of entries instead of their
size in bytes.
A failed ALLOCATE of a component of a coarray freed the token of the
component, so retrying the ALLOCATE freed it twice. The token is now kept.
Assisted-by: Claude Opus 5.5
PR libfortran/127751
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_register): Keep the token of a
component when its allocation fails.
* caf/shmem/alloc.c (get_memory_by_id_internal): Free the memory and
return NULL when the id cannot be entered into the hashmap.
* caf/shmem/hashmap.c (enlarge_hashmap_mem): Return false, leaving
the hashmap unchanged, when the shared memory is exhausted. Free the
old table with its size in bytes.
(resize_hm): Return false and restore the old table on failure.
Free the old table with its size in bytes.
(hashmap_set): Return false when the hashmap cannot be enlarged.
* caf/shmem/hashmap.h (hashmap_set): Return bool.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/alloc_pool_exhausted_3.f90: New test.
---From b6de88fb206c5a9a8811094ed6e3004795be620d Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Thu, 29 Oct 2026 19:30:05 -0400
Subject: [PATCH 2/2] libgfortran: [PR127751] caf_shmem: report a full table of
coarray ids
When ALLOCATE of a coarray needed a larger table of coarray ids and the
shared memory pool could not hold it, the image error terminated while
holding the allocator lock, so the other images hung. The table is now
left unchanged and the failure is reported through STAT= and ERRMSG=.
Old tables were also freed with their number of entries instead of their
size in bytes.
A failed ALLOCATE of a component of a coarray freed the token of the
component, so retrying the ALLOCATE freed it twice. The token is now kept.
Assisted-by: Claude Opus 5.5
PR libfortran/127751
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_register): Keep the token of a
component when its allocation fails.
* caf/shmem/alloc.c (get_memory_by_id_internal): Free the memory and
return NULL when the id cannot be entered into the hashmap.
* caf/shmem/hashmap.c (enlarge_hashmap_mem): Return false, leaving
the hashmap unchanged, when the shared memory is exhausted. Free the
old table with its size in bytes.
(resize_hm): Return false and restore the old table on failure.
Free the old table with its size in bytes.
(hashmap_set): Return false when the hashmap cannot be enlarged.
* caf/shmem/hashmap.h (hashmap_set): Return bool.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/alloc_pool_exhausted_3.f90: New test.
---
.../coarray/alloc_pool_exhausted_3.f90 | 96 +++++++++++++++++++
libgfortran/caf/shmem.c | 7 +-
libgfortran/caf/shmem/alloc.c | 8 +-
libgfortran/caf/shmem/hashmap.c | 52 +++++++---
libgfortran/caf/shmem/hashmap.h | 5 +-
5 files changed, 150 insertions(+), 18 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/alloc_pool_exhausted_3.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_pool_exhausted_3.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_pool_exhausted_3.f90
new file mode 100644
index 00000000000..e15fcca0aee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/alloc_pool_exhausted_3.f90
@@ -0,0 +1,96 @@
+! { dg-do run }
+! PR libfortran/127751
+!
+! ALLOCATE of a coarray reports a nonzero STAT= and ERRMSG= when the shared
+! memory pool cannot hold the enlarged table of coarray ids. Without the fix
+! the image error terminates and the other images hang. Retrying a failed
+! ALLOCATE of a component of a coarray must not free its token twice.
+
+module m
+ implicit none
+ type :: t
+ integer(1), allocatable :: c(:)
+ end type t
+ integer :: nok = 0, st_fail = 0
+ character(80) :: msg_fail = ''
+contains
+ subroutine try (x)
+ integer(8), allocatable, intent(inout) :: x[:]
+
+ if (st_fail /= 0) return
+ allocate (x[*], stat=st_fail, errmsg=msg_fail)
+ if (st_fail == 0) nok = nok + 1
+ end subroutine try
+ subroutine rel (x)
+ integer(8), allocatable, intent(inout) :: x[:]
+
+ if (allocated (x)) deallocate (x)
+ end subroutine rel
+end module m
+
+program alloc_pool_exhausted_3
+ use m
+ implicit none
+ integer, parameter :: nres = 48
+ type(t), allocatable :: f(:)[:]
+ integer(8), allocatable, codimension[:] :: x01, x02, x03, x04, x05, x06, x07, x08
+ integer(8), allocatable, codimension[:] :: x09, x10, x11, x12, x13, x14, x15, x16
+ integer(8), allocatable, codimension[:] :: x17, x18, x19, x20, x21, x22, x23, x24
+ integer(8), allocatable, codimension[:] :: x25, x26, x27, x28, x29, x30, x31, x32
+ integer(8), allocatable, codimension[:] :: x33, x34, x35, x36, x37, x38, x39, x40
+ integer(8), allocatable :: y[:]
+ integer :: i, k, n, st, nb
+
+ if (num_images () < 2) stop
+ allocate (f(nres + 100)[*])
+
+ ! Keep blocks the size of a small coarray in reserve
+ do i = 1, nres
+ allocate (f(i)%c(8 * num_images ()))
+ end do
+ sync all
+ ! Use up every block of at least 64 bytes
+ n = nres
+ do k = 30, 6, -1
+ do
+ if (n == size (f)) stop 1
+ allocate (f(n + 1)%c(2**k), stat=st)
+ if (st /= 0) exit
+ n = n + 1
+ end do
+ end do
+ sync all
+ do i = 1, nres
+ deallocate (f(i)%c)
+ end do
+ sync all
+
+ ! New coarray ids eventually need a larger table than the pool can hold
+ call try (x01); call try (x02); call try (x03); call try (x04); call try (x05)
+ call try (x06); call try (x07); call try (x08); call try (x09); call try (x10)
+ call try (x11); call try (x12); call try (x13); call try (x14); call try (x15)
+ call try (x16); call try (x17); call try (x18); call try (x19); call try (x20)
+ call try (x21); call try (x22); call try (x23); call try (x24); call try (x25)
+ call try (x26); call try (x27); call try (x28); call try (x29); call try (x30)
+ call try (x31); call try (x32); call try (x33); call try (x34); call try (x35)
+ call try (x36); call try (x37); call try (x38); call try (x39); call try (x40)
+ if (st_fail == 0) stop 2
+ if (len_trim (msg_fail) == 0) stop 3
+ if (nok == 0) stop 4
+
+ ! The table and the freed blocks can be reused
+ call rel (x01); call rel (x02); call rel (x03); call rel (x04); call rel (x05)
+ call rel (x06); call rel (x07); call rel (x08); call rel (x09); call rel (x10)
+ call rel (x11); call rel (x12); call rel (x13); call rel (x14); call rel (x15)
+ call rel (x16); call rel (x17); call rel (x18); call rel (x19); call rel (x20)
+ call rel (x21); call rel (x22); call rel (x23); call rel (x24); call rel (x25)
+ call rel (x26); call rel (x27); call rel (x28); call rel (x29); call rel (x30)
+ call rel (x31); call rel (x32); call rel (x33); call rel (x34); call rel (x35)
+ call rel (x36); call rel (x37); call rel (x38); call rel (x39); call rel (x40)
+ allocate (y[*], stat=st)
+ if (st /= 0) stop 5
+ y = this_image ()
+ sync all
+ nb = mod (this_image (), num_images ()) + 1
+ if (y[nb] /= nb) stop 6
+end program alloc_pool_exhausted_3
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 88b800e5247..d49e063d16c 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -360,7 +360,12 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
memory may be lost. */
if (mem)
alloc_free_memory_with_id (&local->ai, next_memid);
- free (*token);
+ /* The token of a component was registered before; keep it. */
+ if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+ {
+ free (*token);
+ *token = NULL;
+ }
caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
return;
}
diff --git a/libgfortran/caf/shmem/alloc.c b/libgfortran/caf/shmem/alloc.c
index 003cdb642ea..e6cbf95c415 100644
--- a/libgfortran/caf/shmem/alloc.c
+++ b/libgfortran/caf/shmem/alloc.c
@@ -106,7 +106,13 @@ get_memory_by_id_internal (alloc *iface, size_t size, memid id, bool *created)
*created = false;
return NULL;
}
- hashmap_set (&iface->hm, id, NULL, shared_ptr, size);
+ if (!hashmap_set (&iface->hm, id, NULL, shared_ptr, size))
+ {
+ allocator_shared_free (&iface->alloc, shared_ptr, size);
+ if (created)
+ *created = false;
+ return NULL;
+ }
if (created)
*created = true;
diff --git a/libgfortran/caf/shmem/hashmap.c b/libgfortran/caf/shmem/hashmap.c
index 70206416f2c..4ae683dc18c 100644
--- a/libgfortran/caf/shmem/hashmap.c
+++ b/libgfortran/caf/shmem/hashmap.c
@@ -194,19 +194,24 @@ hm_search_result_contains (hashmap_search_result *res)
return !SHMPTR_IS_NULL (res->p);
}
-/* Enlarge hashmap memory. */
+/* Enlarge hashmap memory. Returns false, leaving the hashmap unchanged, when
+ the shared memory is exhausted. */
-static void
+static bool
enlarge_hashmap_mem (hashmap *hm, hashmap_entry **data, bool f)
{
- shared_mem_ptr old_data_p;
+ shared_mem_ptr old_data_p, new_data_p;
size_t old_size;
old_data_p = hm->s->data;
old_size = hm->s->size;
- hm->s->data = allocator_shared_malloc_or_die (hm->a, (hm->s->size *= 2)
- * sizeof (hashmap_entry));
+ new_data_p
+ = allocator_shared_malloc (hm->a, 2 * old_size * sizeof (hashmap_entry));
+ if (SHMPTR_IS_NULL (new_data_p))
+ return false;
+ hm->s->data = new_data_p;
+ hm->s->size = 2 * old_size;
hm->s->bitnum++;
*data = get_data (hm);
@@ -215,12 +220,15 @@ enlarge_hashmap_mem (hashmap *hm, hashmap_entry **data, bool f)
.id = 0, .p = SHMPTR_NULL, .s = 0, .max_lookahead = 0, .refcnt = 0 });
if (f)
- allocator_shared_free (hm->a, old_data_p, old_size);
+ allocator_shared_free (hm->a, old_data_p,
+ old_size * sizeof (hashmap_entry));
+ return true;
}
-/* Resize hashmap. */
+/* Resize hashmap. Returns false, leaving the hashmap unchanged, when the
+ shared memory is exhausted. */
-static void
+static bool
resize_hm (hashmap *hm, hashmap_entry **data)
{
shared_mem_ptr old_data_p;
@@ -229,6 +237,7 @@ resize_hm (hashmap *hm, hashmap_entry **data)
ssize_t new_offset, inital_index, new_index;
memid id;
ssize_t max_lookahead;
+ int old_bitnum;
/* old_data points to the old block containing the hashmap. We
redistribute the data from there into the new block. */
@@ -236,8 +245,10 @@ resize_hm (hashmap *hm, hashmap_entry **data)
old_data_p = hm->s->data;
old_data = *data;
old_size = hm->s->size;
+ old_bitnum = hm->s->bitnum;
- enlarge_hashmap_mem (hm, &new_data, false);
+ if (!enlarge_hashmap_mem (hm, &new_data, false))
+ return false;
retry_resize:
for (size_t i = 0; i < old_size; i++)
{
@@ -252,7 +263,16 @@ retry_resize:
again. */
if (new_offset == -1)
{
- enlarge_hashmap_mem (hm, &new_data, true);
+ if (!enlarge_hashmap_mem (hm, &new_data, true))
+ {
+ /* Drop the partly filled table and restore the old one. */
+ allocator_shared_free (hm->a, hm->s->data,
+ hm->s->size * sizeof (hashmap_entry));
+ hm->s->data = old_data_p;
+ hm->s->size = old_size;
+ hm->s->bitnum = old_bitnum;
+ return false;
+ }
goto retry_resize; /* Sue me. */
}
@@ -268,13 +288,15 @@ retry_resize:
.max_lookahead = new_data[new_index].max_lookahead,
.refcnt = old_data[i].refcnt });
}
- allocator_shared_free (hm->a, old_data_p, old_size);
+ allocator_shared_free (hm->a, old_data_p,
+ old_size * sizeof (hashmap_entry));
*data = new_data;
+ return true;
}
/* Set an entry in the hashmap. */
-void
+bool
hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,
shared_mem_ptr p, size_t size)
{
@@ -289,13 +311,14 @@ hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,
{
data[hsr->res_offset].s = size;
data[hsr->res_offset].p = p;
- return;
+ return true;
}
expected_offset = get_expected_offset (hm, id);
while ((delta = scan_empty (hm, expected_offset)) == -1)
{
- resize_hm (hm, &data);
+ if (!resize_hm (hm, &data))
+ return false;
expected_offset = get_expected_offset (hm, id);
}
@@ -312,6 +335,7 @@ hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,
n_ent++;
/* TODO: Shouldn't reset refcnt, but this doesn't matter at the
moment because of the way the function is used. */
+ return true;
}
/* Change the refcount of a hashmap entry. */
diff --git a/libgfortran/caf/shmem/hashmap.h b/libgfortran/caf/shmem/hashmap.h
index d1659ac4be8..64bb86dc3aa 100644
--- a/libgfortran/caf/shmem/hashmap.h
+++ b/libgfortran/caf/shmem/hashmap.h
@@ -81,9 +81,10 @@ bool hm_search_result_contains (hashmap_search_result *);
/* Sets the hashmap entry for memid to shared_mem_ptr and
size_t. Optionally, if a hashmap_search_result is supplied, it is
- used to make the lookup faster. */
+ used to make the lookup faster. Returns false when the hashmap
+ cannot be enlarged. */
-void hashmap_set (hashmap *, memid, hashmap_search_result *, shared_mem_ptr p,
+bool hashmap_set (hashmap *, memid, hashmap_search_result *, shared_mem_ptr p,
size_t);
/* Increments the hashmap entry for memid. Optionally, if a
--
2.56.0
