https://gcc.gnu.org/g:909075f102c0ddd8568c6871c03d1dce027ced32
commit r17-4660-g909075f102c0ddd8568c6871c03d1dce027ced32 Author: Jerry DeLisle <[email protected]> Date: Thu Sep 24 12:39:51 2026 -0700 libgfortran: [PR127347] caf_shmem: report a terminated image in a collective A collective subroutine whose barrier was abandoned because an image of the team terminated reported this with a runtime error, and so terminated the remaining images even when a STAT argument was present. F2023 16.6 assigns STAT_STOPPED_IMAGE, or STAT_FAILED_IMAGE, to the STAT argument in that case and leaves the A argument undefined; an error condition without a STAT argument still is error termination. Pass the abandoned barrier up to the collective and classify it the same way an image control statement does. Assisted-by: Claude Opus 5 PR libfortran/127347 libgfortran/ChangeLog: * caf/shmem.c (_gfortran_caf_co_broadcast, _gfortran_caf_co_sum) (_gfortran_caf_co_min, _gfortran_caf_co_max) (_gfortran_caf_co_reduce): Report a terminated image of the team through STAT. * caf/shmem/collective_subroutine.c (collsub_sync): Return whether the images were synchronized. (collsub_reduce_array, collsub_broadcast_array): Likewise. Give up when an image of the team terminated. * caf/shmem/collective_subroutine.h (collsub_reduce_array) (collsub_broadcast_array): Adjust. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/collective_stopped_2.f90: New test. Diff: --- .../gfortran.dg/coarray/collective_stopped_2.f90 | 32 +++++++++++++++++++ libgfortran/caf/shmem.c | 16 +++++++--- libgfortran/caf/shmem/collective_subroutine.c | 37 ++++++++++++---------- libgfortran/caf/shmem/collective_subroutine.h | 7 ++-- 4 files changed, 68 insertions(+), 24 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/coarray/collective_stopped_2.f90 b/gcc/testsuite/gfortran.dg/coarray/collective_stopped_2.f90 new file mode 100644 index 000000000000..2a4e4f3207ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/collective_stopped_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! An image terminating while the others are inside a collective subroutine +! has to be reported through stat=, not by terminating them. + +program collective_stopped_2 + use iso_fortran_env, only : stat_stopped_image + implicit none + integer :: s[*] + integer :: st, img + + if (num_images () == 1) stop + img = max (num_images () / 2, 2) + s = this_image () + if (this_image () == img) then + call spin () + stop + end if + + st = 0 + call co_sum (s, stat=st) + if (st /= stat_stopped_image) stop 1 +contains + subroutine spin () + integer :: c + integer(kind=8) :: v + v = 2 + do c = 1, 20000000 + v = mod (v * 2, 1999619_8) + end do + end subroutine +end program collective_stopped_2 diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c index 00d851ab5395..aacb1fd6f86f 100644 --- a/libgfortran/caf/shmem.c +++ b/libgfortran/caf/shmem.c @@ -859,7 +859,9 @@ _gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat, NULL, stat)) return; - collsub_broadcast_array (desc, mapped_index); + /* A terminated image leaves the collective incomplete (F2023 16.6). */ + if (!collsub_broadcast_array (desc, mapped_index)) + HEALTH_CHECK (stat, errmsg, errmsg_len); } #define GEN_OP(name, op, type) \ @@ -961,7 +963,8 @@ _gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat, SWITCH_TYPE_KIND (sum) - collsub_reduce_array (desc, mapped_index, opr, 0, 0); + if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0)) + HEALTH_CHECK (stat, errmsg, errmsg_len); } void @@ -986,7 +989,8 @@ _gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat, SWITCH_TYPE_KIND (min) - collsub_reduce_array (desc, mapped_index, opr, 0, 0); + if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0)) + HEALTH_CHECK (stat, errmsg, errmsg_len); } void @@ -1011,7 +1015,8 @@ _gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat, SWITCH_TYPE_KIND (max) - collsub_reduce_array (desc, mapped_index, opr, 0, 0); + if (!collsub_reduce_array (desc, mapped_index, opr, 0, 0)) + HEALTH_CHECK (stat, errmsg, errmsg_len); } void @@ -1034,7 +1039,8 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *), NULL, stat)) return; - collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len); + if (!collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len)) + HEALTH_CHECK (stat, errmsg, errmsg_len); } void diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c index f97789cab1c3..911c54acbee9 100644 --- a/libgfortran/caf/shmem/collective_subroutine.c +++ b/libgfortran/caf/shmem/collective_subroutine.c @@ -22,7 +22,6 @@ a copy of the GCC Runtime Library Exception along with this program; see the files COPYING3 and COPYING.RUNTIME respectively. If not, see <http://www.gnu.org/licenses/>. */ -#include "../caf_error.h" #include "collective_subroutine.h" #include "supervisor.h" #include "teams_mgmt.h" @@ -221,16 +220,15 @@ get_collsub_buf (size_t size) /* This function syncs all images with one another. It will only return once all images have called it. The reduction is laid out over a fixed set of - images, so it cannot be completed once an image of the team terminated. */ + images, so it cannot be completed once an image of the team terminated. + Returns false in that case. */ -static void +static bool collsub_sync (void) { counter_barrier *barrier = &caf_current_team->u.image_info->collsub.barrier; - if (!counter_barrier_wait_abortable (barrier)) - caf_runtime_error ("Image terminated while executing a collective " - "subroutine"); + return counter_barrier_wait_abortable (barrier); } typedef void *(*red_op) (void *, void *); @@ -321,7 +319,7 @@ gen_reduction (const int type, const size_t sz, const int flags) /* Having result_image == -1 means allreduce. */ -void +bool collsub_reduce_array (gfc_descriptor_t *desc, int result_image, void *(*op) (void *, void *), int opr_flags, int str_len __attribute__ ((unused))) @@ -339,7 +337,7 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image, packed = pack_array_prepare (&pi, desc); if (pi.num_elem == 0) - return; + return true; elem_size = GFC_DESCRIPTOR_SIZE (desc); this_image_size_bytes = elem_size * pi.num_elem; @@ -354,7 +352,8 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image, pack_array_finish (&pi, desc, this_image_buf); assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags); - collsub_sync (); + if (!collsub_sync ()) + return false; for (; ((this_img_id >> cbit) & 1) == 0 && (caf_current_team->u.image_info->image_count.count >> cbit) != 0; @@ -371,11 +370,13 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image, ++i, roll_iter += elem_size, src_iter += elem_size) assign (op, roll_iter, src_iter, elem_size); } - collsub_sync (); + if (!collsub_sync ()) + return false; } for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0; cbit++) - collsub_sync (); + if (!collsub_sync ()) + return false; if (result_image < 0 || result_image == this_image.image_num) { @@ -385,14 +386,14 @@ collsub_reduce_array (gfc_descriptor_t *desc, int result_image, unpack_array_finish (&pi, desc, buffer); } - collsub_sync (); + return collsub_sync (); } /* 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. */ -void +bool collsub_broadcast_array (gfc_descriptor_t *desc, int source_image) { void *buffer; @@ -403,7 +404,7 @@ collsub_broadcast_array (gfc_descriptor_t *desc, int source_image) packed = pack_array_prepare (&pi, desc); if (pi.num_elem == 0) - return; + return true; if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER) { @@ -423,16 +424,18 @@ collsub_broadcast_array (gfc_descriptor_t *desc, int source_image) memcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes); else pack_array_finish (&pi, desc, buffer); - collsub_sync (); + if (!collsub_sync ()) + return false; } else { - collsub_sync (); + if (!collsub_sync ()) + return false; if (packed) memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes); else unpack_array_finish (&pi, desc, buffer); } - collsub_sync (); + return collsub_sync (); } diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h index 76b1610f9765..01ad34adf5f7 100644 --- a/libgfortran/caf/shmem/collective_subroutine.h +++ b/libgfortran/caf/shmem/collective_subroutine.h @@ -42,9 +42,12 @@ typedef struct collsub_shared void collsub_init_supervisor (collsub_shared *, allocator *, const int init_num_images); -void collsub_broadcast_array (gfc_descriptor_t *, int); +/* Both return false when an image of the current team terminated before the + collective could be completed. */ -void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *), +bool collsub_broadcast_array (gfc_descriptor_t *, int); + +bool collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *), int opr_flags, int str_len); #endif
