See attached patch.
Regression tested on x86_64.
I hope this is the last of the important caf issues. After this I will wotk on
the TEAMs related issues with -fcoarray=single
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127973] caf_shmem: collectives report an
exhausted pool
When a collective subroutine could not grow the team's buffer in the
shared memory pool, the image growing it error terminated while holding
the buffer's mutex, so the other images hung instead of getting STAT=
and ERRMSG=. The buffer was also allocated without the allocator lock.
get_collsub_buf now allocates under the allocator lock and, on failure,
sets a flag in the team's collective state, so that every image of the
collective fails; the images clear the flag between two barrier rounds.
collsub_reduce_array and collsub_broadcast_array return a collsub_result,
and the _gfortran_caf_co_* entry points report an exhausted pool through
STAT= and ERRMSG=.
Assisted-by: Claude Opus 5.5
PR libfortran/127973
libgfortran/ChangeLog:
* caf/shmem.c (report_collective): New function.
(_gfortran_caf_co_broadcast, _gfortran_caf_co_sum)
(_gfortran_caf_co_min, _gfortran_caf_co_max)
(_gfortran_caf_co_reduce): Use it.
* caf/shmem/collective_subroutine.c (collsub_init_supervisor):
Initialize alloc_failed.
(get_collsub_buf): Return false instead of terminating when the
buffer cannot be grown. Take the allocator lock.
(collsub_no_memory): New function.
(collsub_reduce_array, collsub_broadcast_array): Return a
collsub_result. Use collsub_no_memory.
* caf/shmem/collective_subroutine.h (struct collsub_shared): Add
alloc_failed.
(collsub_result): New enum.
(collsub_broadcast_array, collsub_reduce_array): Return it.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/collective_pool_exhausted_1.f90: New test.
---From 42144b05b79d7924af4f288fdebf0fb6d46b8111 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 17 Oct 2026 09:59:16 -0700
Subject: [PATCH] libgfortran: [PR127973] caf_shmem: collectives report an
exhausted pool
When a collective subroutine could not grow the team's buffer in the
shared memory pool, the image growing it error terminated while holding
the buffer's mutex, so the other images hung instead of getting STAT=
and ERRMSG=. The buffer was also allocated without the allocator lock.
get_collsub_buf now allocates under the allocator lock and, on failure,
sets a flag in the team's collective state, so that every image of the
collective fails; the images clear the flag between two barrier rounds.
collsub_reduce_array and collsub_broadcast_array return a collsub_result,
and the _gfortran_caf_co_* entry points report an exhausted pool through
STAT= and ERRMSG=.
Assisted-by: Claude Opus 5.5
PR libfortran/127973
libgfortran/ChangeLog:
* caf/shmem.c (report_collective): New function.
(_gfortran_caf_co_broadcast, _gfortran_caf_co_sum)
(_gfortran_caf_co_min, _gfortran_caf_co_max)
(_gfortran_caf_co_reduce): Use it.
* caf/shmem/collective_subroutine.c (collsub_init_supervisor):
Initialize alloc_failed.
(get_collsub_buf): Return false instead of terminating when the
buffer cannot be grown. Take the allocator lock.
(collsub_no_memory): New function.
(collsub_reduce_array, collsub_broadcast_array): Return a
collsub_result. Use collsub_no_memory.
* caf/shmem/collective_subroutine.h (struct collsub_shared): Add
alloc_failed.
(collsub_result): New enum.
(collsub_broadcast_array, collsub_reduce_array): Return it.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/collective_pool_exhausted_1.f90: New test.
---
.../coarray/collective_pool_exhausted_1.f90 | 45 ++++++++
libgfortran/caf/shmem.c | 37 +++++--
libgfortran/caf/shmem/collective_subroutine.c | 103 ++++++++++++------
libgfortran/caf/shmem/collective_subroutine.h | 21 +++-
4 files changed, 155 insertions(+), 51 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/collective_pool_exhausted_1.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/collective_pool_exhausted_1.f90 b/gcc/testsuite/gfortran.dg/coarray/collective_pool_exhausted_1.f90
new file mode 100644
index 00000000000..23e53f3e9c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/collective_pool_exhausted_1.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! PR 127973
+!
+! A collective whose buffer does not fit into the shared memory reports a
+! nonzero STAT= and ERRMSG= on every image, and later collectives still work.
+! Without the fix one image error terminates and the others hang.
+
+program collective_pool_exhausted_1
+ implicit none
+ real(8), allocatable :: a(:)
+ integer :: st, i, n
+ character(80) :: msg
+
+ n = num_images ()
+ ! 8 MiB per image, more than caf.exp's 2 MiB pool.
+ allocate (a(1024*1024))
+
+ do i = 1, 2
+ a = this_image ()
+ msg = ''
+ call co_sum (a, stat=st, errmsg=msg)
+ if (st == 0) then
+ if (any (a /= n * (n + 1) / 2)) stop 1
+ else
+ if (index (msg, 'exhausted') == 0) stop 2
+ if (any (a /= this_image ())) stop 3
+ end if
+
+ a = this_image ()
+ msg = ''
+ call co_broadcast (a, 1, stat=st, errmsg=msg)
+ if (st == 0) then
+ if (any (a /= 1)) stop 4
+ else
+ if (index (msg, 'exhausted') == 0) stop 5
+ end if
+ end do
+
+ st = this_image ()
+ call co_sum (st)
+ if (st /= n * (n + 1) / 2) stop 6
+ a(1:4) = this_image ()
+ call co_max (a(1:4))
+ if (any (a(1:4) /= n)) stop 7
+end program collective_pool_exhausted_1
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index e84796aa584..ea026dc8805 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -833,6 +833,21 @@ check_map_team (int *remote_index, int *this_index, const int image_index,
return check;
}
+/* Report the outcome R of a collective through STAT and ERRMSG. A
+ terminated image leaves the collective incomplete (F2023 16.6). */
+
+static void
+report_collective (collsub_result r, int *stat, char *errmsg,
+ size_t errmsg_len)
+{
+ if (r == COLLSUB_TERMINATED)
+ HEALTH_CHECK (stat, errmsg, errmsg_len);
+ else if (r == COLLSUB_NO_MEMORY)
+ caf_internal_error ("Shared memory exhausted; increase "
+ "GFORTRAN_SHARED_MEMORY_SIZE",
+ stat, errmsg, errmsg_len);
+}
+
void
_gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat,
char *errmsg __attribute__ ((unused)),
@@ -849,9 +864,8 @@ _gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat,
NULL, stat))
return;
- /* A terminated image leaves the collective incomplete (F2023 16.6). */
- if (!collsub_broadcast_array (desc, mapped_index))
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ report_collective (collsub_broadcast_array (desc, mapped_index), stat,
+ errmsg, errmsg_len);
}
#define GEN_OP(name, op, type) \
@@ -953,8 +967,8 @@ _gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat,
SWITCH_TYPE_KIND (sum)
- if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0))
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ report_collective (collsub_reduce_array (desc, mapped_index, opr, 0, 0),
+ stat, errmsg, errmsg_len);
}
void
@@ -979,8 +993,8 @@ _gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat,
SWITCH_TYPE_KIND (min)
- if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0))
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ report_collective (collsub_reduce_array (desc, mapped_index, opr, 0, 0),
+ stat, errmsg, errmsg_len);
}
void
@@ -1005,8 +1019,8 @@ _gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat,
SWITCH_TYPE_KIND (max)
- if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0))
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ report_collective (collsub_reduce_array (desc, mapped_index, opr, 0, 0),
+ stat, errmsg, errmsg_len);
}
void
@@ -1029,8 +1043,9 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *),
NULL, stat))
return;
- if (!collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len))
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ report_collective (collsub_reduce_array (desc, mapped_index, opr, opr_flags,
+ desc_len),
+ stat, errmsg, errmsg_len);
}
void
diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c
index d9118cdc95f..2fef8ae5014 100644
--- a/libgfortran/caf/shmem/collective_subroutine.c
+++ b/libgfortran/caf/shmem/collective_subroutine.c
@@ -188,35 +188,45 @@ collsub_init_supervisor (collsub_shared *cis, allocator *al,
cis->curr_size = init_size;
cis->collsub_buf = allocator_shared_malloc_or_die (al, init_size);
+ cis->alloc_failed = false;
counter_barrier_init (&cis->barrier, init_num_images);
initialize_shared_mutex (&cis->mutex);
}
-static void *
-get_collsub_buf (size_t size)
-{
- void *ret;
+/* Point *BUF to the current team's buffer, grown to SIZE bytes if needed.
+ Returns false on every image of the collective when it cannot be grown. */
- caf_shmem_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
- /* curr_size is always at least sizeof(double), so we don't need to worry
- about size == 0. */
- if (size > caf_current_team->u.image_info->collsub.curr_size)
+static bool
+get_collsub_buf (size_t size, void **buf)
+{
+ collsub_shared *cs = &caf_current_team->u.image_info->collsub;
+ allocator *a = alloc_get_allocator (&local->ai);
+ bool ok;
+
+ caf_shmem_mutex_lock (&cs->mutex);
+ /* curr_size is at least sizeof(double) unless growing failed, so we don't
+ need to worry about size == 0. */
+ if (size > cs->curr_size && !cs->alloc_failed)
{
- allocator_shared_free (
- alloc_get_allocator (&local->ai),
- caf_current_team->u.image_info->collsub.collsub_buf,
- caf_current_team->u.image_info->collsub.curr_size);
- caf_current_team->u.image_info->collsub.collsub_buf
- = allocator_shared_malloc_or_die (alloc_get_allocator (&local->ai),
- size);
- caf_current_team->u.image_info->collsub.curr_size = size;
+ allocator_lock (a);
+ if (!SHMPTR_IS_NULL (cs->collsub_buf))
+ allocator_shared_free (a, cs->collsub_buf, cs->curr_size);
+ cs->collsub_buf = allocator_shared_malloc (a, size);
+ allocator_unlock (a);
+ if (SHMPTR_IS_NULL (cs->collsub_buf))
+ {
+ cs->curr_size = 0;
+ cs->alloc_failed = true;
+ }
+ else
+ cs->curr_size = size;
}
-
- ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,
- &local->sm);
- caf_shmem_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
- return ret;
+ ok = !cs->alloc_failed;
+ if (ok)
+ *buf = SHMPTR_AS (void *, cs->collsub_buf, &local->sm);
+ caf_shmem_mutex_unlock (&cs->mutex);
+ return ok;
}
/* This function syncs all images with one another. It will only return once
@@ -232,6 +242,26 @@ collsub_sync (void)
return counter_barrier_wait_abortable (barrier, NULL);
}
+/* Finish a collective whose buffer could not be grown. alloc_failed is
+ cleared between two rounds, so that every image has seen it and none has
+ started the next collective. */
+
+static collsub_result
+collsub_no_memory (void)
+{
+ collsub_shared *cs = &caf_current_team->u.image_info->collsub;
+
+ if (!collsub_sync ())
+ return COLLSUB_TERMINATED;
+ if (caf_current_team->index == 0)
+ {
+ caf_shmem_mutex_lock (&cs->mutex);
+ cs->alloc_failed = false;
+ caf_shmem_mutex_unlock (&cs->mutex);
+ }
+ return collsub_sync () ? COLLSUB_NO_MEMORY : COLLSUB_TERMINATED;
+}
+
typedef void *(*red_op) (void *, void *);
typedef void (*ass_op) (red_op, void *, void *, size_t);
@@ -320,7 +350,7 @@ gen_reduction (const int type, const size_t sz, const int flags)
/* Having result_image == -1 means allreduce. */
-bool
+collsub_result
collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
void *(*op) (void *, void *), int opr_flags,
int str_len __attribute__ ((unused)))
@@ -338,13 +368,15 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
packed = pack_array_prepare (&pi, desc);
if (pi.num_elem == 0)
- return true;
+ return COLLSUB_DONE;
elem_size = GFC_DESCRIPTOR_SIZE (desc);
this_image_size_bytes = elem_size * pi.num_elem;
- buffer = get_collsub_buf (
- this_image_size_bytes * caf_current_team->u.image_info->image_map_size);
+ if (!get_collsub_buf (this_image_size_bytes
+ * caf_current_team->u.image_info->image_map_size,
+ &buffer))
+ return collsub_no_memory ();
this_image_buf = buffer + this_image_size_bytes * this_img_id;
if (packed)
@@ -354,7 +386,7 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags);
if (!collsub_sync ())
- return false;
+ return COLLSUB_TERMINATED;
for (; ((this_img_id >> cbit) & 1) == 0
&& (caf_current_team->u.image_info->image_map_size >> cbit) != 0;
@@ -372,12 +404,12 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
assign (op, roll_iter, src_iter, elem_size);
}
if (!collsub_sync ())
- return false;
+ return COLLSUB_TERMINATED;
}
for (; (caf_current_team->u.image_info->image_map_size >> cbit) != 0;
cbit++)
if (!collsub_sync ())
- return false;
+ return COLLSUB_TERMINATED;
if (result_image < 0 || result_image == this_image.image_num)
{
@@ -387,14 +419,14 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
unpack_array_finish (&pi, desc, buffer);
}
- return collsub_sync ();
+ return collsub_sync () ? COLLSUB_DONE : COLLSUB_TERMINATED;
}
/* Do not use sync_all(), because the program should deadlock in the case that
* some images are on a sync_all barrier while others are in a collective
* subroutine. */
-bool
+collsub_result
collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
{
void *buffer;
@@ -405,7 +437,7 @@ collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
packed = pack_array_prepare (&pi, desc);
if (pi.num_elem == 0)
- return true;
+ return COLLSUB_DONE;
if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER)
{
@@ -417,7 +449,8 @@ collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
else
elem_size = (index_type) GFC_DESCRIPTOR_SIZE (desc);
size_bytes = elem_size * pi.num_elem;
- buffer = get_collsub_buf (size_bytes);
+ if (!get_collsub_buf (size_bytes, &buffer))
+ return collsub_no_memory ();
if (source_image == this_image.image_num)
{
@@ -426,17 +459,17 @@ collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
else
pack_array_finish (&pi, desc, buffer);
if (!collsub_sync ())
- return false;
+ return COLLSUB_TERMINATED;
}
else
{
if (!collsub_sync ())
- return false;
+ return COLLSUB_TERMINATED;
if (packed)
memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes);
else
unpack_array_finish (&pi, desc, buffer);
}
- return collsub_sync ();
+ return collsub_sync () ? COLLSUB_DONE : COLLSUB_TERMINATED;
}
diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h
index 01ad34adf5f..c6f30ea3382 100644
--- a/libgfortran/caf/shmem/collective_subroutine.h
+++ b/libgfortran/caf/shmem/collective_subroutine.h
@@ -35,6 +35,9 @@ typedef struct collsub_shared
{
size_t curr_size;
shared_mem_ptr collsub_buf;
+ /* Set when growing collsub_buf failed, until every image of the team has
+ seen it. Guarded by mutex. */
+ bool alloc_failed;
counter_barrier barrier;
caf_shmem_mutex mutex;
} collsub_shared;
@@ -42,12 +45,20 @@ typedef struct collsub_shared
void collsub_init_supervisor (collsub_shared *, allocator *,
const int init_num_images);
-/* Both return false when an image of the current team terminated before the
- collective could be completed. */
+typedef enum
+{
+ COLLSUB_DONE,
+ /* An image of the current team terminated before the collective could be
+ completed. */
+ COLLSUB_TERMINATED,
+ /* The shared memory cannot hold the collective's buffer. */
+ COLLSUB_NO_MEMORY
+} collsub_result;
-bool collsub_broadcast_array (gfc_descriptor_t *, int);
+collsub_result collsub_broadcast_array (gfc_descriptor_t *, int);
-bool collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *),
- int opr_flags, int str_len);
+collsub_result collsub_reduce_array (gfc_descriptor_t *, int,
+ void *(*) (void *, void *),
+ int opr_flags, int str_len);
#endif
--
2.56.0
