Le 15/09/2026 à 17:53, Jerry D a écrit :
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.
---
---
.../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
I'm not sure about the two testcases. Aren't they invalid?
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);
Can we use counter_barrier_add (t->...image_count, -1) instead, so that
the function update_teams_images can be removed?
+}
+
/* 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);
}
That part looks good overall.
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;
That part looks good as well.
It seems the if and else cases could use some refactoring after this.
And then there is the rest, which I quite don't understand, so I'll have
to come back to it later.
Generally speaking, getting multithreading right is hard with all the
risks of deadlocks and race conditions. But here the patch adds
callbacks to the party, that are passed from function to function; it's
a nightmare.
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)
I don't understand the need for this "recheck" callback, and the
repeated wakeups to recheck.
If both an image reaching the barrier and an image terminating normally
decrease the count, it should reach zero, shouldn't it? And then every
waiting thread should get its wakeup signal?
That's all for now; I'll try to come back to this later.
