See the attached patch.
This takes care of the STAT= problem identified here:
https://gcc.gnu.org/pipermail/fortran/2026-September/064686.html
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
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.
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.
---From a09c79a2beb519398cce5c56e66f328fd813003e Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Thu, 24 Sep 2026 12:39:51 -0700
Subject: [PATCH] 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.
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.
---
.../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(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/collective_stopped_2.f90
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 00000000000..2a4e4f3207e
--- /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 00d851ab539..aacb1fd6f86 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 f97789cab1c..911c54acbee 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 76b1610f976..01ad34adf5f 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
--
2.55.0
