See attached patch. This fixes a hang issue I found while testing under heavy
loads. This patch goes in after the fix for PR127702 which is pending approval.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127684] caf_shmem: SYNC IMAGES hangs when an
image of the set terminates
A stopped image in the image set now aborts the images waiting in SYNC
IMAGES and takes back their unmatched synchronizations, under the lock
of the sync table and before the stop is visible; a failed image is
skipped and the active images are synchronized. STAT= is set only when
an image of the set terminated during the statement.
PR libfortran/127684
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_sync_images): Do not return early for
a stopped or failed image. Check the images only when one of them
terminated.
(mark_stopped): Use sync_table_terminated.
(_gfortran_caf_fail_image): Likewise.
* caf/shmem/supervisor.c (supervisor_main_loop): Likewise. Do not
signal all images waiting in sync_table.
* caf/shmem/sync.c (set_table_parts): New function.
(sync_init): Use it.
(sync_init_supervisor): Allocate the image sets of the waiting
images and the aborted flags.
(stopped_image_in): New function.
(sync_table): Return whether an image of the set terminated. Only
synchronize memory when an image of the set stopped. Record the
image set and end the wait when aborted.
(sync_table_terminated): New function.
* caf/shmem/sync.h (sync_t): Add waiting and aborted.
(sync_table): Return bool.
(sync_table_terminated): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/sync_images_failed_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_2.f90: New test.
---
From 4e137f2c7c284eb50f1e8b28c445be541bb5bb7b Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Wed, 30 Sep 2026 19:26:47 -0700
Subject: [PATCH] libgfortran: [PR127684] caf_shmem: SYNC IMAGES hangs when an
image of the set terminates
A stopped image in the image set now aborts the images waiting in SYNC
IMAGES and takes back their unmatched synchronizations, under the lock
of the sync table and before the stop is visible; a failed image is
skipped and the active images are synchronized. STAT= is set only when
an image of the set terminated during the statement.
PR libfortran/127684
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_sync_images): Do not return early for
a stopped or failed image. Check the images only when one of them
terminated.
(mark_stopped): Use sync_table_terminated.
(_gfortran_caf_fail_image): Likewise.
* caf/shmem/supervisor.c (supervisor_main_loop): Likewise. Do not
signal all images waiting in sync_table.
* caf/shmem/sync.c (set_table_parts): New function.
(sync_init): Use it.
(sync_init_supervisor): Allocate the image sets of the waiting
images and the aborted flags.
(stopped_image_in): New function.
(sync_table): Return whether an image of the set terminated. Only
synchronize memory when an image of the set stopped. Record the
image set and end the wait when aborted.
(sync_table_terminated): New function.
* caf/shmem/sync.h (sync_t): Add waiting and aborted.
(sync_table): Return bool.
(sync_table_terminated): Declare.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/sync_images_failed_1.f90: New test.
* gfortran.dg/coarray/sync_images_stopped_2.f90: New test.
---
.../coarray/sync_images_failed_1.f90 | 50 ++++++++++
.../coarray/sync_images_stopped_2.f90 | 53 +++++++++++
libgfortran/caf/shmem.c | 34 ++-----
libgfortran/caf/shmem/supervisor.c | 11 +--
libgfortran/caf/shmem/sync.c | 93 +++++++++++++++++--
libgfortran/caf/shmem/sync.h | 16 +++-
6 files changed, 213 insertions(+), 44 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_images_failed_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_2.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_images_failed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_images_failed_1.f90
new file mode 100644
index 00000000000..71da5317725
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_failed_1.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! PR 127684
+!
+! SYNC IMAGES (STAT=) with a failed image in the image set synchronizes the
+! active images of the set (F2023 11.7.11), both for an image that already
+! waits in the statement when the image fails and for one that arrives later.
+
+program sync_images_failed_1
+ use iso_fortran_env, only : atomic_int_kind, stat_failed_image
+ implicit none
+ integer(atomic_int_kind) :: arrived[*], a
+ integer :: st, x[*]
+
+ if (num_images () < 3) stop
+ arrived = 0
+ x = 0
+ sync all
+
+ select case (this_image ())
+ case (1)
+ call atomic_define (arrived[3], 1)
+ st = 0
+ sync images ([2, 3], stat=st)
+ if (st /= stat_failed_image) stop 1
+ if (x[2] /= 42) stop 2
+ case (2)
+ do while (image_status (3) /= stat_failed_image)
+ end do
+ x = 42
+ st = 0
+ sync images ([1, 3], stat=st)
+ if (st /= stat_failed_image) stop 3
+ case (3)
+ a = 0
+ do while (a == 0)
+ call atomic_ref (a, arrived)
+ end do
+ call spin ()
+ fail image
+ end select
+contains
+ subroutine spin ()
+ integer :: c
+ integer(kind=8) :: v
+ v = 2
+ do c = 1, 20000000
+ v = mod (v * 2, 199679_8)
+ end do
+ end subroutine
+end program sync_images_failed_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_2.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_2.f90
new file mode 100644
index 00000000000..3002cf926df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_2.f90
@@ -0,0 +1,53 @@
+! { dg-do run }
+! PR 127684
+!
+! SYNC IMAGES (STAT=) with a stopped image in the image set has the effect of
+! SYNC MEMORY (F2023 11.7.11), both for an image that already waits in the
+! statement when the image stops and for one that arrives later. The next
+! SYNC IMAGES of these two images has to pair with each other.
+
+program sync_images_stopped_2
+ use iso_fortran_env, only : atomic_int_kind, stat_stopped_image
+ implicit none
+ integer(atomic_int_kind) :: arrived[*], a
+ integer :: st, x[*]
+
+ if (num_images () < 3) stop
+ arrived = 0
+ x = 0
+ sync all
+
+ select case (this_image ())
+ case (1)
+ call atomic_define (arrived[3], 1)
+ st = 0
+ sync images ([2, 3], stat=st)
+ if (st /= stat_stopped_image) stop 1
+ sync images (2)
+ if (x[2] /= 42) stop 2
+ case (2)
+ do while (image_status (3) /= stat_stopped_image)
+ end do
+ st = 0
+ sync images ([1, 3], stat=st)
+ if (st /= stat_stopped_image) stop 3
+ x = 42
+ sync images (1)
+ case (3)
+ a = 0
+ do while (a == 0)
+ call atomic_ref (a, arrived)
+ end do
+ call spin ()
+ stop
+ end select
+contains
+ subroutine spin ()
+ integer :: c
+ integer(kind=8) :: v
+ v = 2
+ do c = 1, 20000000
+ v = mod (v * 2, 199679_8)
+ end do
+ end subroutine
+end program sync_images_stopped_2
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 08ae3113da5..d5d725b40e6 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -528,23 +528,6 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
if (images[c] > 0 && images[c] <= max_id)
{
mapped_images[c] = map[images[c] - 1];
- switch (this_image.supervisor->images[mapped_images[c]].status)
- {
- case IMAGE_SUCCESS:
- caf_internal_error ("SYNC IMAGES: Image %d is stopped", stat,
- errmsg, errmsg_len, images[c]);
- /* We can come here only, when stat is non-NULL. */
- *stat = CAF_STAT_STOPPED_IMAGE;
- return;
- case IMAGE_FAILED:
- caf_internal_error ("SYNC IMAGES: Image %d has failed", stat,
- errmsg, errmsg_len, images[c]);
- /* We can come here only, when stat is non-NULL. */
- *stat = CAF_STAT_FAILED_IMAGE;
- return;
- default:
- break;
- }
for (int i = 0; i < c; ++i)
if (mapped_images[c] == mapped_images[i])
{
@@ -570,8 +553,12 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
HEALTH_CHECK (stat, errmsg, errmsg_len);
__asm__ __volatile__ ("" ::: "memory");
- sync_table (&local->si, mapped_images, count);
- if (count > 0)
+ if (!sync_table (&local->si, mapped_images, count))
+ {
+ if (stat)
+ *stat = 0;
+ }
+ else if (count > 0)
check_health (mapped_images, count, stat, errmsg, errmsg_len);
else
HEALTH_CHECK (stat, errmsg, errmsg_len);
@@ -589,11 +576,7 @@ mark_stopped (void)
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);
- }
+ sync_table_terminated (&local->si, this_image.image_num, true);
leave_teams (true);
}
@@ -657,8 +640,7 @@ void
_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);
+ sync_table_terminated (&local->si, this_image.image_num, false);
leave_teams (false);
exit (0);
}
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index 246f98aab63..67dffcd23d0 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -432,8 +432,7 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
image already. */
if (m->images[j].status == IMAGE_OK)
{
- m->images[j].status = IMAGE_SUCCESS;
- atomic_fetch_add (&m->finished_images, 1);
+ sync_table_terminated (&local->si, j, true);
}
}
else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus))
@@ -484,8 +483,7 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
already, e.g. by a STOP with a non-zero stop code. */
if (m->images[j].status == IMAGE_OK)
{
- m->images[j].status = IMAGE_FAILED;
- atomic_fetch_add (&m->failed_images, 1);
+ sync_table_terminated (&local->si, j, false);
/* The image did not leave the barriers of its teams, so do
it for it. */
update_registered_teams ();
@@ -496,11 +494,6 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
*exit_code = 1;
}
}
- /* Trigger waiting sync images aka sync_table. */
- for (j = 0; j < local->total_num_images; j++)
- caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
- m->sync_shared.sync_images_cond_vars,
- &local->sm)[j]);
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/sync.c b/libgfortran/caf/shmem/sync.c
index 9deb31f0871..38cbc4655f3 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -42,21 +42,35 @@ unlock_table (sync_t *si)
caf_shmem_mutex_unlock (&si->cis->sync_images_table_lock);
}
+/* Set the pointers to the parts of the sync images table. */
+
+static void
+set_table_parts (sync_t *si, int *table)
+{
+ const size_t n = local->total_num_images;
+
+ si->table = table;
+ si->waiting = table + n * n;
+ si->aborted = table + 2 * n * n;
+}
+
void
sync_init (sync_t *si, shared_memory sm)
{
- *si = (sync_t) {
- &this_image.supervisor->sync_shared,
- SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm),
- SHMPTR_AS (caf_shmem_condvar *,
- this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};
+ si->cis = &this_image.supervisor->sync_shared;
+ si->triggers = SHMPTR_AS (caf_shmem_condvar *,
+ si->cis->sync_images_cond_vars, sm);
+ set_table_parts (si, SHMPTR_AS (int *, si->cis->sync_images_table, sm));
}
void
sync_init_supervisor (sync_t *si, alloc *ai)
{
const int num_images = local->total_num_images;
- const size_t table_size_in_bytes = sizeof (int) * num_images * num_images;
+ /* The counts of the synchronizations, the image sets of the waiting images
+ and a flag per image. */
+ const size_t table_size_in_bytes
+ = sizeof (int) * (2 * num_images * num_images + num_images);
si->cis = &this_image.supervisor->sync_shared;
@@ -71,7 +85,7 @@ sync_init_supervisor (sync_t *si, alloc *ai)
= allocator_shared_malloc (alloc_get_allocator (ai),
sizeof (caf_shmem_condvar) * num_images);
- si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
+ set_table_parts (si, SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem));
si->triggers
= SHMPTR_AS (caf_shmem_condvar *, si->cis->sync_images_cond_vars, ai->mem);
@@ -81,7 +95,18 @@ sync_init_supervisor (sync_t *si, alloc *ai)
memset (si->table, 0, table_size_in_bytes);
}
-void
+/* Whether one of the SIZE IMAGES has stopped. */
+
+static bool
+stopped_image_in (const int *images, int size)
+{
+ for (int i = 0; i < size; ++i)
+ if (this_image.supervisor->images[images[i]].status == IMAGE_SUCCESS)
+ return true;
+ return false;
+}
+
+bool
sync_table (sync_t *si, int *images, int size)
{
/* The variable `table` is an N x N matrix, where N is the number of all
@@ -97,6 +122,7 @@ sync_table (sync_t *si, int *images, int size)
/* 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;
+ bool terminated;
int i;
if (size <= 0)
@@ -106,6 +132,16 @@ sync_table (sync_t *si, int *images, int size)
}
lock_table (si);
+ /* With a stopped image in the set this only has the effect of SYNC
+ MEMORY; failed images are skipped (F2023 11.7.11). */
+ if (stopped_image_in (images, size))
+ {
+ unlock_table (si);
+ return true;
+ }
+ for (i = 0; i < size; ++i)
+ si->waiting[images[i] + img_c * this_image.image_num] = 1;
+ si->aborted[this_image.image_num] = 0;
for (i = 0; i < size; ++i)
{
if (this_image.supervisor->images[images[i]].status != IMAGE_OK)
@@ -115,6 +151,9 @@ sync_table (sync_t *si, int *images, int size)
}
for (;;)
{
+ /* An image of the set stopped, see sync_table_terminated. */
+ if (si->aborted[this_image.image_num])
+ break;
for (i = 0; i < size; ++i)
if (this_image.supervisor->images[images[i]].status == IMAGE_OK
&& table[images[i] + img_c * this_image.image_num]
@@ -125,6 +164,44 @@ sync_table (sync_t *si, int *images, int size)
caf_shmem_cond_wait (&si->triggers[this_image.image_num],
&si->cis->sync_images_table_lock);
}
+ terminated = si->aborted[this_image.image_num];
+ for (i = 0; i < size; ++i)
+ {
+ si->waiting[images[i] + img_c * this_image.image_num] = 0;
+ if (this_image.supervisor->images[images[i]].status != IMAGE_OK)
+ terminated = true;
+ }
+ unlock_table (si);
+ return terminated;
+}
+
+void
+sync_table_terminated (sync_t *si, int image, bool stopped)
+{
+ volatile int *table = si->table;
+ const size_t img_c = local->total_num_images;
+
+ lock_table (si);
+ for (size_t j = 0; j < img_c; ++j)
+ {
+ if (!si->waiting[image + img_c * j])
+ continue;
+ if (stopped)
+ {
+ /* Take back the synchronizations of image J no image has matched
+ yet, before any image can see that IMAGE stopped. */
+ for (size_t k = 0; k < img_c; ++k)
+ if (si->waiting[k + img_c * j]
+ && table[k + img_c * j] > table[j + img_c * k])
+ --table[k + img_c * j];
+ si->aborted[j] = 1;
+ }
+ caf_shmem_cond_signal (&si->triggers[j]);
+ }
+ atomic_fetch_add (stopped ? &this_image.supervisor->finished_images
+ : &this_image.supervisor->failed_images, 1);
+ this_image.supervisor->images[image].status
+ = stopped ? IMAGE_SUCCESS : IMAGE_FAILED;
unlock_table (si);
}
diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h
index d7b96992840..f902c1f9b57 100644
--- a/libgfortran/caf/shmem/sync.h
+++ b/libgfortran/caf/shmem/sync.h
@@ -41,6 +41,10 @@ typedef struct {
sync_shared *cis;
int *table; // we can cache the table and the trigger pointers here
caf_shmem_condvar *triggers;
+ /* The image sets of the images waiting in sync_table, and whether their
+ synchronization was aborted. */
+ int *waiting;
+ int *aborted;
} sync_t;
typedef caf_shmem_mutex caf_shmem_lock_t;
@@ -69,7 +73,17 @@ void sync_team (caf_shmem_team_t team);
bool sync_team_unless_stopped (caf_shmem_team_t team, int *terminated);
-void sync_table (sync_t *, int *, int);
+/* Synchronize with the SIZE images in the array, or with the images of the
+ current team when SIZE is zero. Returns true, when an image of the set
+ terminated before the images synchronized. */
+
+bool sync_table (sync_t *, int *, int);
+
+/* Set the status of IMAGE, which terminated, to stopped or failed, count it
+ and wake the images waiting for it in sync_table. When it STOPPED, the
+ synchronizations of these images are aborted. */
+
+void sync_table_terminated (sync_t *, int image, bool stopped);
void lock_alloc_lock (sync_t *);
--
2.55.0
