The attached patch is version 2 of 2 of 3.
(Patch 1 of 3 was approved previously and is unchanged.)
This responds to Mikael's comment about using callbacks. Callbacks are
eliminated in this version.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127347] caf_shmem: do not wait for
terminated images
When an image terminated normally or with FAIL IMAGE, the other images
kept counting it in their team barriers and blocked forever in the next
SYNC ALL. An image executing STOP or FAIL IMAGE now drops out of the
barriers of every team it is a member of before it exits. Lowering the
count wakes the images already waiting once it reaches zero.
An image that terminates without STOP or FAIL IMAGE, e.g. by a signal,
cannot do so. It now initiates error termination of all images, as for
ERROR STOP, instead of being marked failed. Only the fork based
supervisor does so.
SYNC IMAGES indexed its synchronization table with the team's image
count as the row stride. That count shrinks once an image has
terminated, although the table is allocated for all images. Use the
total number of images, and handle an image list and * alike.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (mark_stopped): New function.
(_gfortran_caf_stop_numeric, _gfortran_caf_stop_str): Call it.
(_gfortran_caf_fail_image): Call leave_teams.
* caf/shmem/supervisor.c (supervisor_main_loop): Terminate all
images when an image terminated without STOP or FAIL IMAGE.
* caf/shmem/sync.c (sync_table): Use the total number of images as
the row stride. Handle an image list and all images alike.
* caf/shmem/teams_mgmt.c (leave_teams): New function.
* caf/shmem/teams_mgmt.h (leave_teams): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/fail_image_sync_1.f90: New test.
* gfortran.dg/coarray/signal_sync_1.f90: New test.
* gfortran.dg/coarray/stop_sync_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_1.f90: New test.
---From c893aa07b06f608a7d4bb569f1a6b49726143f08 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 19 Sep 2026 12:24:04 -0700
Subject: [PATCH v2 2/3] libgfortran: [PR127347] caf_shmem: do not wait for
terminated images
When an image terminated normally or with FAIL IMAGE, the other images
kept counting it in their team barriers and blocked forever in the next
SYNC ALL. An image executing STOP or FAIL IMAGE now drops out of the
barriers of every team it is a member of before it exits. Lowering the
count wakes the images already waiting once it reaches zero.
An image that terminates without STOP or FAIL IMAGE, e.g. by a signal,
cannot do so. It now initiates error termination of all images, as for
ERROR STOP, instead of being marked failed. Only the fork based
supervisor does so.
SYNC IMAGES indexed its synchronization table with the team's image
count as the row stride. That count shrinks once an image has
terminated, although the table is allocated for all images. Use the
total number of images, and handle an image list and * alike.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (mark_stopped): New function.
(_gfortran_caf_stop_numeric, _gfortran_caf_stop_str): Call it.
(_gfortran_caf_fail_image): Call leave_teams.
* caf/shmem/supervisor.c (supervisor_main_loop): Terminate all
images when an image terminated without STOP or FAIL IMAGE.
* caf/shmem/sync.c (sync_table): Use the total number of images as
the row stride. Handle an image list and all images alike.
* caf/shmem/teams_mgmt.c (leave_teams): New function.
* caf/shmem/teams_mgmt.h (leave_teams): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/fail_image_sync_1.f90: New test.
* gfortran.dg/coarray/signal_sync_1.f90: New test.
* gfortran.dg/coarray/stop_sync_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_1.f90: New test.
---
.../gfortran.dg/coarray/fail_image_sync_1.f90 | 19 ++++++
.../gfortran.dg/coarray/signal_sync_1.f90 | 18 ++++++
.../gfortran.dg/coarray/stop_sync_1.f90 | 17 +++++
.../coarray/sync_images_stopped_1.f90 | 16 +++++
libgfortran/caf/shmem.c | 21 +++++++
libgfortran/caf/shmem/supervisor.c | 13 +++-
libgfortran/caf/shmem/sync.c | 63 +++++++------------
libgfortran/caf/shmem/teams_mgmt.c | 9 +++
libgfortran/caf/shmem/teams_mgmt.h | 5 ++
9 files changed, 139 insertions(+), 42 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/fail_image_sync_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_1.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/fail_image_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/fail_image_sync_1.f90
new file mode 100644
index 00000000000..87b2abbcb95
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/fail_image_sync_1.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+!
+! FAIL IMAGE on one image must not block the remaining images in SYNC ALL.
+! They synchronize among themselves and get STAT_FAILED_IMAGE.
+
+program fail_image_sync_1
+ use iso_fortran_env, only: STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, st
+
+ sync all
+ if (num_images () > 1 .and. this_image () == num_images ()) fail image
+
+ do i = 1, 5
+ st = 0
+ sync all (stat=st)
+ end do
+ if (num_images () > 1 .and. st /= STAT_FAILED_IMAGE) stop 1
+end program fail_image_sync_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90
new file mode 100644
index 00000000000..25cba7bcb92
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-shouldfail "an image killed by a signal terminates all images" }
+!
+! An image killed by a signal initiates error termination of all images.
+! Without that the surviving images block in the SYNC ALL below until the
+! test times out.
+
+program signal_sync_1
+ implicit none
+ integer :: i
+
+ sync all
+ if (this_image () == num_images ()) call abort ()
+
+ do i = 1, 100
+ sync all
+ end do
+end program signal_sync_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
new file mode 100644
index 00000000000..cb41610aaf9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
@@ -0,0 +1,17 @@
+! { dg-do run }
+!
+! A normal STOP on one image must not block the surviving images in the
+! SYNC ALL statements that follow.
+
+program stop_sync_1
+ implicit none
+ integer :: i, st
+
+ sync all
+ if (num_images () > 1 .and. this_image () == num_images ()) stop
+
+ do i = 1, 5
+ st = 0
+ sync all (stat=st)
+ end do
+end program stop_sync_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_1.f90
new file mode 100644
index 00000000000..eecfc70f877
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_1.f90
@@ -0,0 +1,16 @@
+! { dg-do run }
+!
+! SYNC IMAGES (*) has to keep working after an image terminated normally.
+
+program sync_images_stopped_1
+ implicit none
+ integer :: i, st
+
+ sync all
+ if (num_images () > 1 .and. this_image () == num_images ()) stop
+
+ do i = 1, 5
+ st = 0
+ sync images (*, stat=st)
+ end do
+end program sync_images_stopped_1
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index c6735146a2e..89fad8a8f4b 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -570,6 +570,24 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
extern void _gfortran_report_exception (void);
+/* Tell the supervisor that this image terminated normally and drop it from
+ the barriers of its teams. */
+
+static void
+mark_stopped (void)
+{
+ if (!this_image.supervisor || this_image.image_num < 0)
+ return;
+
+ if (this_image.supervisor->images[this_image.image_num].status == IMAGE_OK)
+ {
+ this_image.supervisor->images[this_image.image_num].status
+ = IMAGE_SUCCESS;
+ atomic_fetch_add (&this_image.supervisor->finished_images, 1);
+ }
+ leave_teams ();
+}
+
/* Tell the supervisor that this image error stopped, so that it can terminate
all other images. */
@@ -589,6 +607,7 @@ _gfortran_caf_stop_numeric (int stop_code, bool quiet)
_gfortran_report_exception ();
fprintf (stderr, "STOP %d\n", stop_code);
}
+ mark_stopped ();
exit (stop_code);
}
@@ -603,6 +622,7 @@ _gfortran_caf_stop_str (const char *string, size_t len, bool quiet)
fputc (*(string++), stderr);
fputs ("\n", stderr);
}
+ mark_stopped ();
exit (0);
}
@@ -630,6 +650,7 @@ _gfortran_caf_fail_image (void)
fputs ("IMAGE FAILED!\n", stderr);
this_image.supervisor->images[this_image.image_num].status = IMAGE_FAILED;
atomic_fetch_add (&this_image.supervisor->failed_images, 1);
+ leave_teams ();
exit (0);
}
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index ff4a592b6f2..1a28aadd63a 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -478,8 +478,17 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
WTERMSIG (chstatus), finished_pid);
continue;
}
- m->images[j].status = IMAGE_FAILED;
- atomic_fetch_add (&m->failed_images, 1);
+ /* An image terminating without STOP or FAIL IMAGE, e.g. by a
+ signal, initiates error termination of all images. */
+ if (m->images[j].status == IMAGE_OK)
+ {
+ kill_all_images (m);
+ while (wait (NULL) > 0)
+ ;
+ *exit_code = WIFEXITED (chstatus) ? WEXITSTATUS (chstatus)
+ : WTERMSIG (chstatus);
+ return 0;
+ }
if (*exit_code < WTERMSIG (chstatus))
*exit_code = WTERMSIG (chstatus);
else if (*exit_code == 0)
diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c
index 76ae0e53ccf..f1d5bedbc8e 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -94,53 +94,36 @@ sync_table (sync_t *si, int *images, int size)
command is completed.
*/
volatile int *table = si->table;
+ /* The table is allocated for all images, so the row stride is the total
+ number of images and not the (shrinking) number of images in a team. */
+ const size_t img_c = local->total_num_images;
int i;
+ if (size <= 0)
+ {
+ images = caf_current_team->u.image_info->image_map;
+ size = caf_current_team->u.image_info->image_map_size;
+ }
+
lock_table (si);
- if (size > 0)
+ for (i = 0; i < size; ++i)
{
- const size_t img_c = caf_current_team->u.image_info->image_map_size;
- for (i = 0; i < size; ++i)
- {
- ++table[images[i] + img_c * this_image.image_num];
- caf_shmem_cond_signal (&si->triggers[images[i]]);
- }
- for (;;)
- {
- for (i = 0; i < size; ++i)
- if (this_image.supervisor->images[images[i]].status == IMAGE_OK
- && table[images[i] + this_image.image_num * img_c]
- > table[this_image.image_num + images[i] * img_c])
- break;
- if (i == size)
- break;
- caf_shmem_cond_wait (&si->triggers[this_image.image_num],
- &si->cis->sync_images_table_lock);
- }
+ if (this_image.supervisor->images[images[i]].status != IMAGE_OK)
+ continue;
+ ++table[images[i] + img_c * this_image.image_num];
+ caf_shmem_cond_signal (&si->triggers[images[i]]);
}
- else
+ for (;;)
{
- int *map = caf_current_team->u.image_info->image_map;
- size = caf_current_team->u.image_info->image_count.count;
for (i = 0; i < size; ++i)
- {
- if (this_image.supervisor->images[map[i]].status != IMAGE_OK)
- continue;
- ++table[map[i] + size * this_image.image_num];
- caf_shmem_cond_signal (&si->triggers[map[i]]);
- }
- for (;;)
- {
- for (i = 0; i < size; ++i)
- if (this_image.supervisor->images[map[i]].status == IMAGE_OK
- && table[map[i] + size * this_image.image_num]
- > table[this_image.image_num + map[i] * size])
- break;
- if (i == size)
- break;
- caf_shmem_cond_wait (&si->triggers[this_image.image_num],
- &si->cis->sync_images_table_lock);
- }
+ if (this_image.supervisor->images[images[i]].status == IMAGE_OK
+ && table[images[i] + img_c * this_image.image_num]
+ > table[this_image.image_num + img_c * images[i]])
+ break;
+ if (i == size)
+ break;
+ caf_shmem_cond_wait (&si->triggers[this_image.image_num],
+ &si->cis->sync_images_table_lock);
}
unlock_table (si);
}
diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c
index c4a821d5f00..02f37f28590 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -55,6 +55,15 @@ update_teams_images (caf_shmem_team_t team)
caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
}
+void
+leave_teams (void)
+{
+ for (caf_shmem_team_t t = caf_current_team; t; t = t->parent)
+ update_teams_images (t);
+ for (caf_shmem_team_t t = caf_teams_formed; t; t = t->parent)
+ update_teams_images (t);
+}
+
void
check_health (int *stat, char *errmsg, size_t errmsg_len)
{
diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h
index f9da4511128..efeeefc6e24 100644
--- a/libgfortran/caf/shmem/teams_mgmt.h
+++ b/libgfortran/caf/shmem/teams_mgmt.h
@@ -86,6 +86,11 @@ extern caf_shmem_team_t caf_teams_formed;
void update_teams_images (caf_shmem_team_t);
+/* Drop this image, which terminated, from the barriers of all teams it is a
+ member of. */
+
+void leave_teams (void);
+
void check_health (int *, char *, size_t);
#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
--
2.55.0
