https://gcc.gnu.org/g:4eda76ca63df945f4c22d76aeca263bd9457887d
commit r17-4941-g4eda76ca63df945f4c22d76aeca263bd9457887d Author: Jerry DeLisle <[email protected]> Date: Wed Sep 30 19:26:47 2026 -0700 libgfortran: [PR127684] caf_shmem: SYNC IMAGES hang on terminated image SYNC IMAGES hung when an image of the image set stopped or failed while another image of the set was waiting in the statement. An image that found a stopped or failed image in its set returned at once with STAT=, without counting the statement for the other images of the set, so an image already waiting for it was never released. The supervisor, the parent process that starts the images and waits for them to exit, also woke the waiting images without holding the table lock, so a wakeup could be lost. Each image now counts the statement for every active image of its set, also when one of them has stopped, so that corresponding statements keep pairing (F2023 11.7.4). With a stopped image the statement then only has the effect of SYNC MEMORY, and failed images are skipped (F2023 11.7.11). Every change of an image's status to stopped or failed now goes through the new notify_image_terminated, which holds the table lock and wakes every image waiting in SYNC IMAGES. The image sets its own status in STOP or FAIL IMAGE; the supervisor sets it when an image exited or was killed by a signal without doing so. The Windows version of the supervisor is not changed. Assisted-by: Claude Opus 5.5 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 notify_image_terminated. (_gfortran_caf_fail_image): Likewise. * caf/shmem/supervisor.c (supervisor_main_loop): Likewise. Do not signal the images waiting in sync_table. * caf/shmem/sync.c (stopped_image_in): New function. (sync_table): Return whether an image of the set terminated. Stop waiting when an image of the set stopped. (notify_image_terminated): New function. * caf/shmem/sync.h (sync_table): Return bool. (notify_image_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. * gfortran.dg/coarray/sync_images_stopped_3.f90: New test. Diff: --- .../gfortran.dg/coarray/sync_images_failed_1.f90 | 55 ++++++++++++++++++++ .../gfortran.dg/coarray/sync_images_stopped_2.f90 | 58 ++++++++++++++++++++++ .../gfortran.dg/coarray/sync_images_stopped_3.f90 | 40 +++++++++++++++ libgfortran/caf/shmem.c | 34 +++---------- libgfortran/caf/shmem/supervisor.c | 11 +--- libgfortran/caf/shmem/sync.c | 40 ++++++++++++++- libgfortran/caf/shmem/sync.h | 11 +++- 7 files changed, 212 insertions(+), 37 deletions(-) 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 000000000000..c076ee4d88eb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_failed_1.f90 @@ -0,0 +1,55 @@ +! { 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. +! +! Image 1 tells image 3 that it is about to wait for images 2 and 3; image 3 +! spins to give it time to start waiting, then fails. Image 2 executes its +! SYNC IMAGES only after it sees image 3 failed, and image 1 reads X from +! image 2 to check that the two synchronized. Without the fix the test hangs. + +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 000000000000..5d5ac61c83f8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_2.f90 @@ -0,0 +1,58 @@ +! { 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. +! +! Image 1 tells image 3 that it is about to wait for images 2 and 3; image 3 +! spins to give it time to start waiting, then stops. Image 2 executes its +! first SYNC IMAGES only after it sees image 3 stopped, and image 1 checks +! the pairing of the next one through X. Without the fix the test hangs. + +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/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_3.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_3.f90 new file mode 100644 index 000000000000..f479a7a0196c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_images_stopped_3.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! PR 127684 +! +! A SYNC IMAGES that finds a stopped image in its set still counts for the +! correspondence with the other images of the set (F2023 11.7.4), so it +! releases an image whose set does not contain the stopped image. +! +! Image 2 executes its first SYNC IMAGES only after it sees image 3 stopped; +! image 1 may wait for it already or arrive later. Image 1 checks the +! pairing of the next one through X. Without the fix image 1 pairs its first +! SYNC IMAGES with the second one of image 2 and the test hangs. + +program sync_images_stopped_3 + use iso_fortran_env, only : stat_stopped_image + implicit none + integer :: st, x[*] + + if (num_images () < 3) stop + x = 0 + sync all + + select case (this_image ()) + case (1) + st = -1 + sync images (2, stat=st) + if (st /= 0) 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) + stop + end select +end program sync_images_stopped_3 diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c index 08ae3113da5a..7fb23f05e6c3 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); - } + notify_image_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); + notify_image_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 246f98aab631..41e2c1600631 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); + notify_image_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); + notify_image_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 9deb31f0871d..e3041a3c1287 100644 --- a/libgfortran/caf/shmem/sync.c +++ b/libgfortran/caf/shmem/sync.c @@ -81,7 +81,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 +108,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 +118,8 @@ sync_table (sync_t *si, int *images, int size) } lock_table (si); + /* Count the statement even with a stopped image in the set, so that the + counts of the active images keep pairing corresponding statements. */ for (i = 0; i < size; ++i) { if (this_image.supervisor->images[images[i]].status != IMAGE_OK) @@ -115,6 +129,10 @@ sync_table (sync_t *si, int *images, int size) } for (;;) { + /* 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)) + 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 +143,26 @@ 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 = false; + for (i = 0; i < size; ++i) + if (this_image.supervisor->images[images[i]].status != IMAGE_OK) + terminated = true; + unlock_table (si); + return terminated; +} + +void +notify_image_terminated (sync_t *si, int image, bool stopped) +{ + /* Under the table lock, so that an image about to wait in sync_table + either sees the new status or is woken. */ + lock_table (si); + 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; + for (int j = 0; j < local->total_num_images; ++j) + caf_shmem_cond_signal (&si->triggers[j]); unlock_table (si); } diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h index d7b969928409..b359c17cbe3a 100644 --- a/libgfortran/caf/shmem/sync.h +++ b/libgfortran/caf/shmem/sync.h @@ -69,7 +69,16 @@ 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 in sync_table. */ + +void notify_image_terminated (sync_t *, int image, bool stopped); void lock_alloc_lock (sync_t *);
