https://gcc.gnu.org/g:b9da28bcd9af4053544f191f2393a0c79e3d30ae
commit r17-4634-gb9da28bcd9af4053544f191f2393a0c79e3d30ae Author: Jerry DeLisle <[email protected]> Date: Wed Sep 23 13:46:40 2026 -0700 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 executing STOP with a non-zero stop code records that it stopped and then exits with that code. The supervisor marked every image exiting with a non-zero code as failed, so keep the status the image recorded, as is done for an image exiting with zero. 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): Keep the status an image recorded for itself. * 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/stop_sync_1.f90: New test. * gfortran.dg/coarray/sync_images_stopped_1.f90: New test. Diff: --- .../gfortran.dg/coarray/fail_image_sync_1.f90 | 19 +++++++ gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90 | 17 ++++++ .../gfortran.dg/coarray/sync_images_stopped_1.f90 | 16 ++++++ libgfortran/caf/shmem.c | 21 ++++++++ libgfortran/caf/shmem/supervisor.c | 9 +++- libgfortran/caf/shmem/sync.c | 63 ++++++++-------------- libgfortran/caf/shmem/teams_mgmt.c | 9 ++++ libgfortran/caf/shmem/teams_mgmt.h | 6 +++ 8 files changed, 118 insertions(+), 42 deletions(-) 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 000000000000..87b2abbcb953 --- /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/stop_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90 new file mode 100644 index 000000000000..cb41610aaf97 --- /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 000000000000..eecfc70f877d --- /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 c6735146a2eb..89fad8a8f4b3 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 ff4a592b6f28..d63b58e3647f 100644 --- a/libgfortran/caf/shmem/supervisor.c +++ b/libgfortran/caf/shmem/supervisor.c @@ -478,8 +478,13 @@ 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); + /* Only set the status, when it has not been set by the image + 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); + } 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 76ae0e53ccff..f1d5bedbc8e1 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 c4a821d5f009..02f37f285908 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 f9da4511128b..8478281f5d2e 100644 --- a/libgfortran/caf/shmem/teams_mgmt.h +++ b/libgfortran/caf/shmem/teams_mgmt.h @@ -86,6 +86,12 @@ 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. The number of finished or failed images has to be updated + before the call for it to have any effect. */ + +void leave_teams (void); + void check_health (int *, char *, size_t); #define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
