See attached patch 2 of 3.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127347] caf_shmem: do not wait for
stopped images
When an image terminated normally, the other images kept counting it
in their team barriers and blocked forever in the next SYNC ALL. A
stopped image now marks itself and drops out of the barriers of all
teams it is a member of, and images waiting in a barrier re-evaluate
the number of participating images each time they wake up. The
supervisor wakes the images waiting in the initial team's barrier when
it reaps a terminated image.
SYNC IMAGES indexed its synchronization table with the team's image
count as the row stride. That count shrinks once an image has
stopped, although the table is allocated for all images. Use the
total number of images.
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.
* caf/shmem/counter_barrier.c (counter_barrier_wait_recheck): New
function.
(counter_barrier_wait): Use it.
* caf/shmem/counter_barrier.h (counter_barrier_recheck): New type.
(counter_barrier_wait_recheck): Declare.
* caf/shmem/supervisor.c (ensure_shmem_initialization): Record the
initial team's barrier.
(supervisor_main_loop): Wake the images waiting in it when an image
terminated.
* caf/shmem/supervisor.h (supervisor): Add initial_team_barrier.
* caf/shmem/sync.c (sync_table): Use the total number of images as
the row stride.
(sync_all): Use sync_team.
(sync_team): Re-evaluate the participating images on wake up.
* caf/shmem/teams_mgmt.c (update_teams_images_locked): New
function, split out of ...
(update_teams_images): ... this.
* caf/shmem/teams_mgmt.h (update_teams_images_locked): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/stop_sync_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_1.f90: New test.
---From 786a79cd4ab1b638fc2c08a5633014af1cbc717c Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 28 Aug 2026 16:49:41 -0700
Subject: [PATCH 2/3] libgfortran: [PR127347] caf_shmem: do not wait for
stopped images
When an image terminated normally, the other images kept counting it
in their team barriers and blocked forever in the next SYNC ALL. A
stopped image now marks itself and drops out of the barriers of all
teams it is a member of, and images waiting in a barrier re-evaluate
the number of participating images each time they wake up. The
supervisor wakes the images waiting in the initial team's barrier when
it reaps a terminated image.
SYNC IMAGES indexed its synchronization table with the team's image
count as the row stride. That count shrinks once an image has
stopped, although the table is allocated for all images. Use the
total number of images.
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.
* caf/shmem/counter_barrier.c (counter_barrier_wait_recheck): New
function.
(counter_barrier_wait): Use it.
* caf/shmem/counter_barrier.h (counter_barrier_recheck): New type.
(counter_barrier_wait_recheck): Declare.
* caf/shmem/supervisor.c (ensure_shmem_initialization): Record the
initial team's barrier.
(supervisor_main_loop): Wake the images waiting in it when an image
terminated.
* caf/shmem/supervisor.h (supervisor): Add initial_team_barrier.
* caf/shmem/sync.c (sync_table): Use the total number of images as
the row stride.
(sync_all): Use sync_team.
(sync_team): Re-evaluate the participating images on wake up.
* caf/shmem/teams_mgmt.c (update_teams_images_locked): New
function, split out of ...
(update_teams_images): ... this.
* caf/shmem/teams_mgmt.h (update_teams_images_locked): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/stop_sync_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_1.f90: New test.
---
.../gfortran.dg/coarray/stop_sync_1.f90 | 17 +++++++++++++
.../coarray/sync_images_stopped_1.f90 | 16 +++++++++++++
libgfortran/caf/shmem.c | 24 +++++++++++++++++++
libgfortran/caf/shmem/counter_barrier.c | 19 +++++++++++++--
libgfortran/caf/shmem/counter_barrier.h | 11 +++++++++
libgfortran/caf/shmem/supervisor.c | 15 ++++++++++++
libgfortran/caf/shmem/supervisor.h | 3 +++
libgfortran/caf/shmem/sync.c | 19 +++++++++------
libgfortran/caf/shmem/teams_mgmt.c | 12 ++++++++--
libgfortran/caf/shmem/teams_mgmt.h | 5 ++++
10 files changed, 130 insertions(+), 11 deletions(-)
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/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..5c92c13d328 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -570,6 +570,28 @@ _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 wake the images
+ waiting in a team barrier, so that they can drop this image from their
+ barrier count. */
+
+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);
+ }
+
+ /* Drop this image from the barriers of the teams it is a member of. */
+ for (caf_shmem_team_t t = caf_current_team; t; t = t->parent)
+ update_teams_images (t);
+}
+
/* Tell the supervisor that this image error stopped, so that it can terminate
all other images. */
@@ -589,6 +611,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 +626,7 @@ _gfortran_caf_stop_str (const char *string, size_t len, bool quiet)
fputc (*(string++), stderr);
fputs ("\n", stderr);
}
+ mark_stopped ();
exit (0);
}
diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c
index 1993b1ebeea..0e583eecb98 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -55,11 +55,16 @@ counter_barrier_init (counter_barrier *b, int val)
}
void
-counter_barrier_wait (counter_barrier *b)
+counter_barrier_wait_recheck (counter_barrier *b,
+ counter_barrier_recheck recheck, void *data)
{
int wait_group_beginning;
lock_counter_barrier (b);
+ /* Re-check before blocking, so that a terminating image that adjusted the
+ count before this image took the lock is not waited for. */
+ if (recheck)
+ recheck (data);
wait_group_beginning = b->curr_wait_group;
if ((--b->wait_count) <= 0)
@@ -67,7 +72,11 @@ counter_barrier_wait (counter_barrier *b)
else
{
while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
- caf_shmem_cond_wait (&b->cond, &b->mutex);
+ {
+ caf_shmem_cond_wait (&b->cond, &b->mutex);
+ if (recheck)
+ recheck (data);
+ }
}
if (b->wait_count <= 0)
@@ -79,6 +88,12 @@ counter_barrier_wait (counter_barrier *b)
unlock_counter_barrier (b);
}
+void
+counter_barrier_wait (counter_barrier *b)
+{
+ counter_barrier_wait_recheck (b, NULL, NULL);
+}
+
static inline void
change_internal_barrier_count (counter_barrier *b, int val)
{
diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h
index 7d7c724ae06..75cf3e2c41c 100644
--- a/libgfortran/caf/shmem/counter_barrier.h
+++ b/libgfortran/caf/shmem/counter_barrier.h
@@ -73,8 +73,19 @@ void counter_barrier_init_add (counter_barrier *, int);
int counter_barrier_get_count (counter_barrier *);
+/* Called with the barrier's mutex held every time a waiting image wakes up.
+ It allows the caller to adjust the barrier's count, e.g. when images have
+ terminated in the meantime. */
+
+typedef void (*counter_barrier_recheck) (void *);
+
/* Wait for the count in the barrier drop to or below 0. */
void counter_barrier_wait (counter_barrier *);
+/* Like counter_barrier_wait, but call RECHECK with DATA on every wake up. */
+
+void counter_barrier_wait_recheck (counter_barrier *, counter_barrier_recheck,
+ void *);
+
#endif
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index ff4a592b6f2..c5b6209b800 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -231,6 +231,8 @@ ensure_shmem_initialization (void)
{
counter_barrier_init (&caf_initial_team->u.image_info->image_count,
local->total_num_images);
+ this_image.supervisor->initial_team_barrier = AS_SHMPTR (
+ (void *) &caf_initial_team->u.image_info->image_count, local->sm);
collsub_init_supervisor (&caf_initial_team->u.image_info->collsub,
alloc_get_allocator (&local->ai),
local->total_num_images);
@@ -253,6 +255,7 @@ ensure_shmem_initialization (void)
thread_support_init_supervisor ();
counter_barrier_init (&this_image.supervisor->num_active_images,
local->total_num_images);
+ this_image.supervisor->initial_team_barrier = SHMPTR_NULL;
alloc_init_supervisor (&local->ai, &local->sm);
sync_init_supervisor (&local->si, &local->ai);
}
@@ -491,6 +494,18 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
m->sync_shared.sync_images_cond_vars,
&local->sm)[j]);
+ /* Trigger images waiting in the initial team's barrier, e.g. in
+ SYNC ALL, to re-evaluate the number of participating images. */
+ if (!SHMPTR_IS_NULL (m->initial_team_barrier))
+ {
+ counter_barrier *b = SHMPTR_AS (counter_barrier *,
+ m->initial_team_barrier, &local->sm);
+ /* Under the lock, so that an image about to block sees the status
+ of the terminated image instead of the wake up. */
+ caf_shmem_mutex_lock (&b->mutex);
+ caf_shmem_cond_broadcast (&b->cond);
+ caf_shmem_mutex_unlock (&b->mutex);
+ }
counter_barrier_add (&m->num_active_images, -1);
#elif defined(WIN32)
DWORD res = WaitForMultipleObjects (count_waiting, waiting_handles, FALSE,
diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h
index a956092e263..f859bd41256 100644
--- a/libgfortran/caf/shmem/supervisor.h
+++ b/libgfortran/caf/shmem/supervisor.h
@@ -62,6 +62,9 @@ typedef struct supervisor
atomic_int failed_images;
atomic_int finished_images;
counter_barrier num_active_images;
+ /* The initial team's image_count barrier, used by the supervisor to wake
+ images waiting in it when an image has terminated. */
+ shared_mem_ptr initial_team_barrier;
caf_shmem_mutex image_tracker_lock;
#ifdef WIN32
size_t global_used_handles;
diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c
index 76ae0e53ccf..3d03cd67152 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -94,12 +94,14 @@ 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;
lock_table (si);
if (size > 0)
{
- 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];
@@ -121,20 +123,20 @@ sync_table (sync_t *si, int *images, int size)
else
{
int *map = caf_current_team->u.image_info->image_map;
- size = caf_current_team->u.image_info->image_count.count;
+ size = caf_current_team->u.image_info->image_map_size;
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];
+ ++table[map[i] + img_c * 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])
+ && table[map[i] + img_c * this_image.image_num]
+ > table[this_image.image_num + img_c * map[i]])
break;
if (i == size)
break;
@@ -148,13 +150,16 @@ sync_table (sync_t *si, int *images, int size)
void
sync_all (void)
{
- counter_barrier_wait (&caf_current_team->u.image_info->image_count);
+ sync_team (caf_current_team);
}
void
sync_team (caf_shmem_team_t team)
{
- counter_barrier_wait (&team->u.image_info->image_count);
+ /* Re-evaluate the number of participating images on every wake up, so that
+ images terminating while this image waits do not block it forever. */
+ counter_barrier_wait_recheck (&team->u.image_info->image_count,
+ update_teams_images_locked, team);
}
void
diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c
index c4a821d5f00..0e67a7532b5 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -29,9 +29,10 @@ caf_shmem_team_t caf_current_team = NULL, caf_initial_team;
caf_shmem_team_t caf_teams_formed = NULL;
void
-update_teams_images (caf_shmem_team_t team)
+update_teams_images_locked (void *data)
{
- caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex);
+ caf_shmem_team_t team = (caf_shmem_team_t) data;
+
if (team->u.image_info->num_term_images
!= this_image.supervisor->finished_images
+ this_image.supervisor->failed_images)
@@ -52,6 +53,13 @@ update_teams_images (caf_shmem_team_t team)
old_num
- team->u.image_info->num_term_images);
}
+}
+
+void
+update_teams_images (caf_shmem_team_t team)
+{
+ caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex);
+ update_teams_images_locked (team);
caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
}
diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h
index f9da4511128..415ecda2cb8 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);
+/* Same as update_teams_images, but with the team's image_count lock already
+ taken. Shaped as a counter_barrier_recheck callback. */
+
+void update_teams_images_locked (void *);
+
void check_health (int *, char *, size_t);
#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
--
2.55.0
