See attached patch 1 of 3. This patch series resolves some gaps in the handling
of ERROR STOP and syncing of images and TEAMs.
The patches should be applied in order.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127347] caf_shmem: terminate all images
on ERROR STOP
An image executing ERROR STOP exited on its own, and the other images
blocked forever in their next image control statement. ERROR STOP
initiates error termination of all images.
The image now records that it error stopped before exiting, and the
supervisor terminates all other images when it reaps it. Only the
fork based supervisor does so.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (mark_error_stopped): New function.
(_gfortran_caf_error_stop_str, _gfortran_caf_error_stop): Call it.
* caf/shmem/supervisor.c (supervisor_main_loop): Terminate all
images when an image error stopped.
* caf/shmem/supervisor.h (image_status): Add IMAGE_ERROR_STOP.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/error_stop_1.f90: New test.
---From 5ebc43bb10054ab6fca2ff744af6bf2ed3c4f8e7 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 28 Aug 2026 16:40:44 -0700
Subject: [PATCH 1/3] libgfortran: [PR127347] caf_shmem: terminate all images
on ERROR STOP
An image executing ERROR STOP exited on its own, and the other images
blocked forever in their next image control statement. ERROR STOP
initiates error termination of all images.
The image now records that it error stopped before exiting, and the
supervisor terminates all other images when it reaps it. Only the
fork based supervisor does so.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (mark_error_stopped): New function.
(_gfortran_caf_error_stop_str, _gfortran_caf_error_stop): Call it.
* caf/shmem/supervisor.c (supervisor_main_loop): Terminate all
images when an image error stopped.
* caf/shmem/supervisor.h (image_status): Add IMAGE_ERROR_STOP.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/error_stop_1.f90: New test.
---
.../gfortran.dg/coarray/error_stop_1.f90 | 18 ++++++++++++++
libgfortran/caf/shmem.c | 13 ++++++++++
libgfortran/caf/shmem/supervisor.c | 24 ++++++++++++-------
libgfortran/caf/shmem/supervisor.h | 4 +++-
4 files changed, 50 insertions(+), 9 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/error_stop_1.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/error_stop_1.f90 b/gcc/testsuite/gfortran.dg/coarray/error_stop_1.f90
new file mode 100644
index 00000000000..bdbd20f6fd6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/error_stop_1.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-shouldfail "ERROR STOP terminates all images" }
+! { dg-output "ERROR STOP no way back" }
+!
+! ERROR STOP on one image has to terminate all other images. Without that
+! the surviving images block in the SYNC ALL below until the test times out.
+
+program error_stop_all_images
+ implicit none
+ integer :: i
+
+ sync all
+ if (this_image () == num_images ()) error stop "no way back"
+
+ do i = 1, 100
+ sync all
+ end do
+end program error_stop_all_images
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 6288d22204c..c6735146a2e 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -570,6 +570,17 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
extern void _gfortran_report_exception (void);
+/* Tell the supervisor that this image error stopped, so that it can terminate
+ all other images. */
+
+static void
+mark_error_stopped (void)
+{
+ if (this_image.supervisor && this_image.image_num >= 0)
+ this_image.supervisor->images[this_image.image_num].status
+ = IMAGE_ERROR_STOP;
+}
+
void
_gfortran_caf_stop_numeric (int stop_code, bool quiet)
{
@@ -607,6 +618,7 @@ _gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
fputc (*(string++), stderr);
fputs ("\n", stderr);
}
+ mark_error_stopped ();
exit (1);
}
@@ -739,6 +751,7 @@ _gfortran_caf_error_stop (int error, bool quiet)
_gfortran_report_exception ();
fprintf (stderr, "ERROR STOP %d\n", error);
}
+ mark_error_stopped ();
exit (error);
}
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index 0836b89d99f..ff4a592b6f2 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -408,12 +408,24 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
--i;
continue;
}
- if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
+ for (j = 0;
+ j < local->total_num_images && m->images[j].pid != finished_pid;
+ j++)
+ ;
+
+ /* An ERROR STOP on any image terminates all images. */
+ if (j < local->total_num_images
+ && m->images[j].status == IMAGE_ERROR_STOP)
{
- for (j = 0;
- j < local->total_num_images && m->images[j].pid != finished_pid;
- j++)
+ kill_all_images (m);
+ while (wait (NULL) > 0)
;
+ *exit_code = WIFEXITED (chstatus) ? WEXITSTATUS (chstatus) : 1;
+ return 0;
+ }
+
+ if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
+ {
/* Only set the status, when it has not been set by the (failing)
image already. */
if (m->images[j].status == IMAGE_OK)
@@ -424,10 +436,6 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
}
else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus))
{
- for (j = 0;
- j < local->total_num_images && m->images[j].pid != finished_pid;
- j++)
- ;
if (WEXITSTATUS (chstatus) == 210)
{
--i;
diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h
index e5c275b6526..a956092e263 100644
--- a/libgfortran/caf/shmem/supervisor.h
+++ b/libgfortran/caf/shmem/supervisor.h
@@ -41,7 +41,9 @@ typedef enum
IMAGE_UNKNOWN = 0,
IMAGE_OK,
IMAGE_FAILED,
- IMAGE_SUCCESS
+ IMAGE_SUCCESS,
+ /* The image executed an ERROR STOP and requires all images to terminate. */
+ IMAGE_ERROR_STOP
} image_status;
typedef struct
--
2.55.0
