https://gcc.gnu.org/g:b922224de8e06650f86df59143b17c4df0c08381
commit r17-5493-gb922224de8e06650f86df59143b17c4df0c08381 Author: Jerry DeLisle <[email protected]> Date: Sat Oct 17 09:59:16 2026 -0700 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. Diff: --- .../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(-) 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 000000000000..23e53f3e9c9d --- /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 90d069c72158..964c7449e028 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 d9118cdc95f4..2fef8ae50141 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 01ad34adf5f7..c6f30ea33821 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
