https://gcc.gnu.org/g:73309e444dea1ee71346a58b7e4bbaa792de5d19
commit r17-4842-g73309e444dea1ee71346a58b7e4bbaa792de5d19 Author: Jerry DeLisle <[email protected]> Date: Thu Sep 24 12:57:23 2026 -0700 libgfortran: [PR127347] caf_shmem: drop images killed by a signal from teams An image that terminates without STOP or FAIL IMAGE, e.g. when it is killed by a signal, cannot drop itself from the barriers of its teams, so the other images blocked forever in their next image control statement. Only the supervisor notices such an image, and it has no access to the teams the image was a member of. Every team now registers itself with the supervisor when it is formed, which happens once per team, so that the supervisor can walk the teams and do for a killed image what the image itself does for a STOP. Entries are pushed onto the list without a lock, so that an image killed while registering a team cannot block the supervisor. An image killed this way stays a failed image (F2023 5.3.6): the other images of its teams carry on and report it through STAT=. Reporting it needs SYNC ALL and SYNC TEAM to check the images of the team after synchronizing. They only did so when they had not synchronized, which is the case for a stopped image; with a failed image the active images are synchronized (F2023 11.7.11) and the only other check ran before the barrier, so an image failing while the others already waited in the statement left STAT= zero. Assisted-by: Claude Opus 5.5 PR libfortran/127347 libgfortran/ChangeLog: * caf/shmem.c (_gfortran_caf_init): Synchronize without the checks of the SYNC ALL statement. (_gfortran_caf_sync_all, _gfortran_caf_sync_team): Report the images of the team that terminated before the images synchronized. (_gfortran_caf_form_team): Register the team. * caf/shmem/collective_subroutine.c (collsub_sync): Adjust. * caf/shmem/counter_barrier.c (counter_barrier_init): Initialize the new fields. (counter_barrier_add_locked): Count the images removed from the barrier. (next_round): Take that count as a completed round ends. (wait_round, counter_barrier_wait_abortable): Report it for the round the image took part in. * caf/shmem/counter_barrier.h (counter_barrier): Add terminated and round_terminated. (counter_barrier_wait_abortable): Adjust. * caf/shmem/supervisor.c (ensure_shmem_initialization): Initialize the list of teams. Register the initial team. (supervisor_main_loop): Drop an image that terminated without leaving its teams from them. * caf/shmem/supervisor.h (supervisor): Add teams. * caf/shmem/sync.c (sync_all, sync_team_unless_stopped): Report the images that terminated. * caf/shmem/sync.h (sync_all, sync_team_unless_stopped): Adjust. * caf/shmem/teams_mgmt.c (team_terminated_images) (update_teams_images_locked, leave_team): Take the team's image info. (register_team, update_registered_teams): New functions. * caf/shmem/teams_mgmt.h (shmem_image_info): Add next_team. (register_team, update_registered_teams): Declare. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/signal_sync_1.f90: New test. * gfortran.dg/coarray/signal_team_1.f90: New test. * gfortran.dg/coarray/sync_failed_stat_1.f90: New test. Diff: --- .../gfortran.dg/coarray/signal_sync_1.f90 | 22 ++++++ .../gfortran.dg/coarray/signal_team_1.f90 | 26 ++++++++ .../gfortran.dg/coarray/sync_failed_stat_1.f90 | 30 +++++++++ libgfortran/caf/shmem.c | 30 ++++++--- libgfortran/caf/shmem/collective_subroutine.c | 2 +- libgfortran/caf/shmem/counter_barrier.c | 21 ++++-- libgfortran/caf/shmem/counter_barrier.h | 10 ++- libgfortran/caf/shmem/supervisor.c | 5 ++ libgfortran/caf/shmem/supervisor.h | 4 ++ libgfortran/caf/shmem/sync.c | 9 +-- libgfortran/caf/shmem/sync.h | 8 ++- libgfortran/caf/shmem/teams_mgmt.c | 78 ++++++++++++++++------ libgfortran/caf/shmem/teams_mgmt.h | 13 ++++ 13 files changed, 215 insertions(+), 43 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90 new file mode 100644 index 000000000000..416cee6d8e6f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-shouldfail "an image is killed by a signal" } +! +! An image killed by a signal is a failed image (F2023 5.3.6). The other +! images have to continue and report it, instead of blocking in the SYNC ALL +! below until the test times out. + +program signal_sync_1 + use iso_fortran_env, only : stat_failed_image + implicit none + integer :: i, st + + sync all + if (this_image () == num_images ()) call abort () + + do i = 1, 100 + st = 0 + sync all (stat=st) + if (st == stat_failed_image) exit + end do + if (num_images () > 1 .and. st /= stat_failed_image) error stop "not reported" +end program signal_sync_1 diff --git a/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 new file mode 100644 index 000000000000..958801a7fdaa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } } +! { dg-shouldfail "an image is killed by a signal" } +! +! An image killed by a signal while its team is the current one must not +! block the remaining images of that team. + +program signal_team_1 + use iso_fortran_env, only : team_type, stat_failed_image + implicit none + type(team_type) :: t + integer :: i, st + + form team (merge (1, 2, mod (this_image (), 2) == 1), t) + change team (t) + sync all + if (this_image () == num_images ()) call abort () + + do i = 1, 100 + st = 0 + sync all (stat=st) + if (st == stat_failed_image) exit + end do + if (num_images () > 1 .and. st /= stat_failed_image) error stop "not reported" + end team +end program signal_team_1 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_failed_stat_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_failed_stat_1.f90 new file mode 100644 index 000000000000..d6f2d7859996 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_failed_stat_1.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! SYNC ALL synchronizes the active images of a team that contains a failed +! image and has to report it through stat= (F2023 11.7.11), also when the +! image fails while the others already wait in the statement. + +program sync_failed_stat_1 + use iso_fortran_env, only : stat_failed_image + implicit none + integer :: st + + if (num_images () < 2) stop + if (this_image () == 1) then + call spin () + fail image + end if + + st = 0 + sync all (stat=st) + if (st /= stat_failed_image) stop 1 +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_failed_stat_1 diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c index aacb1fd6f86f..fe1e5e293842 100644 --- a/libgfortran/caf/shmem.c +++ b/libgfortran/caf/shmem.c @@ -87,8 +87,10 @@ _gfortran_caf_init (int *argc, char ***argv) if (shared_memory_get_env ()) { - /* This is the initialization of a worker. */ - _gfortran_caf_sync_all (NULL, NULL, 0); + /* This is the initialization of a worker. Synchronize without the + checks of the SYNC ALL statement: an image terminating right after + this barrier is not an error condition here. */ + sync_all (NULL); return; } @@ -480,12 +482,18 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, void _gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len) { + int terminated; + __asm__ __volatile__ ("":::"memory"); - HEALTH_CHECK (stat, errmsg, errmsg_len); CHECK_TEAM_INTEGRITY (caf_current_team); - /* With a stopped image, SYNC ALL only has the effect of SYNC MEMORY. */ - if (!sync_all ()) + /* With a stopped image this only has the effect of SYNC MEMORY, with a + failed image the active images are synchronized; both are reported + (F2023 11.7.11). An image terminating after the images synchronized + was not involved in the statement. */ + if (!sync_all (&terminated) || terminated) HEALTH_CHECK (stat, errmsg, errmsg_len); + else if (stat) + *stat = 0; } @@ -1802,6 +1810,7 @@ _gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index, t->u.image_info->image_map_size = 0; t->u.image_info->num_term_images = 0; t->u.image_info->lastmemid = tmemid; + register_team (t); /* Initialize a freshly created image_map with -1. */ for (int i = 0; i < caf_current_team->u.image_info->image_count.count; ++i) @@ -1941,6 +1950,7 @@ _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, { caf_shmem_team_t team_to_sync = (caf_shmem_team_t) team; caf_shmem_team_t active_team = caf_current_team; + int terminated; if (stat) *stat = 0; @@ -1962,10 +1972,14 @@ _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, return; } - TEAM_HEALTH_CHECK (team_to_sync, stat, errmsg, errmsg_len); - /* With a stopped image, SYNC TEAM only has the effect of SYNC MEMORY. */ - if (!sync_team_unless_stopped (team_to_sync)) + /* With a stopped image this only has the effect of SYNC MEMORY, with a + failed image the active images are synchronized; both are reported + (F2023 11.7.11). An image terminating after the images synchronized + was not involved in the statement. */ + if (!sync_team_unless_stopped (team_to_sync, &terminated) || terminated) TEAM_HEALTH_CHECK (team_to_sync, stat, errmsg, errmsg_len); + else if (stat) + *stat = 0; } int diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c index 911c54acbee9..fbbe93e80f27 100644 --- a/libgfortran/caf/shmem/collective_subroutine.c +++ b/libgfortran/caf/shmem/collective_subroutine.c @@ -228,7 +228,7 @@ collsub_sync (void) { counter_barrier *barrier = &caf_current_team->u.image_info->collsub.barrier; - return counter_barrier_wait_abortable (barrier); + return counter_barrier_wait_abortable (barrier, NULL); } typedef void *(*red_op) (void *, void *); diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c index 8598d79d69dc..1a30e45dda70 100644 --- a/libgfortran/caf/shmem/counter_barrier.c +++ b/libgfortran/caf/shmem/counter_barrier.c @@ -55,6 +55,8 @@ counter_barrier_init (counter_barrier *b, int val) .aborted_round = 0, .abortable_arrivals = 0, .aborting = false, + .terminated = 0, + .round_terminated = 0, .count = val}; initialize_shared_condition (&b->cond, val); initialize_shared_mutex (&b->mutex); @@ -66,8 +68,12 @@ counter_barrier_init (counter_barrier *b, int val) static void next_round (counter_barrier *b, bool abort) { + /* Take the images removed so far as the ones that were involved in a + completed round; an image removed later did not take part in it. */ if (abort) b->aborted_round = b->curr_wait_group; + else + b->round_terminated = b->terminated; ++b->curr_wait_group; b->wait_count = b->count; b->abortable_arrivals = 0; @@ -78,7 +84,7 @@ next_round (counter_barrier *b, bool abort) false, when the round was aborted. */ static bool -wait_round (counter_barrier *b, bool abortable) +wait_round (counter_barrier *b, bool abortable, int *terminated) { const uint64_t round = b->curr_wait_group; @@ -93,6 +99,11 @@ wait_round (counter_barrier *b, bool abortable) if (b->curr_wait_group == round) next_round (b, false); + /* Only an aborted round can end before this image has left a completed + one, and it keeps the snapshot of the completed round. */ + if (terminated) + *terminated = b->round_terminated; + return b->aborted_round != round; } @@ -100,18 +111,18 @@ void counter_barrier_wait (counter_barrier *b) { lock_counter_barrier (b); - while (!wait_round (b, false)) + while (!wait_round (b, false, NULL)) ; unlock_counter_barrier (b); } bool -counter_barrier_wait_abortable (counter_barrier *b) +counter_barrier_wait_abortable (counter_barrier *b, int *terminated) { bool completed; lock_counter_barrier (b); - completed = !b->aborting && wait_round (b, true); + completed = !b->aborting && wait_round (b, true, terminated); unlock_counter_barrier (b); return completed; } @@ -136,6 +147,8 @@ int counter_barrier_add_locked (counter_barrier *c, int val) { int ret; + if (val < 0) + c->terminated -= val; ret = (c->count += val); change_internal_barrier_count (c, val); diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h index 7b6d3d88e711..2eb886545b16 100644 --- a/libgfortran/caf/shmem/counter_barrier.h +++ b/libgfortran/caf/shmem/counter_barrier.h @@ -55,6 +55,10 @@ typedef struct volatile int abortable_arrivals; /* Set once abortable arrivals are no longer to be synchronized. */ volatile bool aborting; + /* The number of images that have been removed from the barrier, and that + number as it was when the last completed round ended. */ + volatile int terminated; + volatile int round_terminated; volatile int count; } counter_barrier; @@ -89,9 +93,11 @@ int counter_barrier_get_count (counter_barrier *); void counter_barrier_wait (counter_barrier *); /* Like counter_barrier_wait, but return false without waiting when the - barrier is aborting, or when the round is aborted. */ + barrier is aborting, or when the round is aborted. TERMINATED, when + given, receives the number of images that had been removed from the + barrier when the round ended; images removed later are not counted. */ -bool counter_barrier_wait_abortable (counter_barrier *); +bool counter_barrier_wait_abortable (counter_barrier *, int *terminated); /* Abort the current round when it has an abortable arrival, and every later abortable arrival. The barrier's lock has to be held. */ diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c index d63b58e3647f..246f98aab631 100644 --- a/libgfortran/caf/shmem/supervisor.c +++ b/libgfortran/caf/shmem/supervisor.c @@ -242,6 +242,7 @@ ensure_shmem_initialization (void) caf_initial_team->u.image_info->lastmemid = 0; for (int i = 0; i < local->total_num_images; ++i) caf_initial_team->u.image_info->image_map[i] = i; + register_team (caf_initial_team); } allocator_unlock (&local->ai.alloc); sync_init (&local->si, &local->sm); @@ -253,6 +254,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->teams = SHMPTR_NULL; alloc_init_supervisor (&local->ai, &local->sm); sync_init_supervisor (&local->si, &local->ai); } @@ -484,6 +486,9 @@ supervisor_main_loop (int *argc __attribute__ ((unused)), { m->images[j].status = IMAGE_FAILED; atomic_fetch_add (&m->failed_images, 1); + /* The image did not leave the barriers of its teams, so do + it for it. */ + update_registered_teams (); } if (*exit_code < WTERMSIG (chstatus)) *exit_code = WTERMSIG (chstatus); diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h index a956092e2635..ea122de12b25 100644 --- a/libgfortran/caf/shmem/supervisor.h +++ b/libgfortran/caf/shmem/supervisor.h @@ -62,6 +62,10 @@ typedef struct supervisor atomic_int failed_images; atomic_int finished_images; counter_barrier num_active_images; + /* The teams formed so far, linked through their next_team, so that the + supervisor can reach the barriers of an image that terminated without + leaving them. Pushed to without a lock. */ + shared_mem_ptr teams; 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 511a85254244..9deb31f0871d 100644 --- a/libgfortran/caf/shmem/sync.c +++ b/libgfortran/caf/shmem/sync.c @@ -129,9 +129,9 @@ sync_table (sync_t *si, int *images, int size) } bool -sync_all (void) +sync_all (int *terminated) { - return sync_team_unless_stopped (caf_current_team); + return sync_team_unless_stopped (caf_current_team, terminated); } void @@ -141,9 +141,10 @@ sync_team (caf_shmem_team_t team) } bool -sync_team_unless_stopped (caf_shmem_team_t team) +sync_team_unless_stopped (caf_shmem_team_t team, int *terminated) { - return counter_barrier_wait_abortable (&team->u.image_info->image_count); + return counter_barrier_wait_abortable (&team->u.image_info->image_count, + terminated); } void diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h index 0aa596c9eff1..d7b969928409 100644 --- a/libgfortran/caf/shmem/sync.h +++ b/libgfortran/caf/shmem/sync.h @@ -52,9 +52,11 @@ void sync_init (sync_t *, shared_memory); void sync_init_supervisor (sync_t *, alloc *); /* Synchronize the images of the current team. Returns false without - synchronizing when a stopped image is a member of the team. */ + synchronizing when a stopped image is a member of the team. TERMINATED, + when given, receives the number of images of the team that had terminated + when the images synchronized. */ -bool sync_all (void); +bool sync_all (int *terminated); /* Prototype for circular dependency break. */ @@ -65,7 +67,7 @@ void sync_team (caf_shmem_team_t team); /* Like sync_all for TEAM. */ -bool sync_team_unless_stopped (caf_shmem_team_t team); +bool sync_team_unless_stopped (caf_shmem_team_t team, int *terminated); void sync_table (sync_t *, int *, int); diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c index d90ece310baf..9e04ee9da10a 100644 --- a/libgfortran/caf/shmem/teams_mgmt.c +++ b/libgfortran/caf/shmem/teams_mgmt.c @@ -42,36 +42,34 @@ count_images (const int *map, int count, image_status status) return n; } -/* Get the number of images of TEAM that have terminated. */ +/* Get the number of images of the team INFO belongs to that have + terminated. */ static int -team_terminated_images (caf_shmem_team_t team) +team_terminated_images (struct shmem_image_info *info) { - const int sz = team->u.image_info->image_map_size; + const int sz = info->image_map_size; int i, term = 0; for (i = 0; i < sz; ++i) - if (this_image.supervisor->images[team->u.image_info->image_map[i]].status - != IMAGE_OK) + if (this_image.supervisor->images[info->image_map[i]].status != IMAGE_OK) ++term; return term; } static void -update_teams_images_locked (caf_shmem_team_t team) +update_teams_images_locked (struct shmem_image_info *info) { - if (team->u.image_info->num_term_images - != this_image.supervisor->finished_images - + this_image.supervisor->failed_images) + if (info->num_term_images != this_image.supervisor->finished_images + + this_image.supervisor->failed_images) { - const int old_num = team->u.image_info->num_term_images; + const int old_num = info->num_term_images; - team->u.image_info->num_term_images = team_terminated_images (team); + info->num_term_images = team_terminated_images (info); - counter_barrier_add_locked (&team->u.image_info->image_count, - old_num - - team->u.image_info->num_term_images); + counter_barrier_add_locked (&info->image_count, + old_num - info->num_term_images); } } @@ -79,20 +77,20 @@ 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); + update_teams_images_locked (team->u.image_info); caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex); } /* Drop this image from the barriers of TEAM. */ static void -leave_team (caf_shmem_team_t team, bool stopped) +leave_team (struct shmem_image_info *info, bool stopped) { - counter_barrier *b = &team->u.image_info->image_count; - counter_barrier *cb = &team->u.image_info->collsub.barrier; + counter_barrier *b = &info->image_count; + counter_barrier *cb = &info->collsub.barrier; caf_shmem_mutex_lock (&b->mutex); - update_teams_images_locked (team); + update_teams_images_locked (info); if (stopped) counter_barrier_abort_locked (b); caf_shmem_mutex_unlock (&b->mutex); @@ -106,9 +104,47 @@ void leave_teams (bool stopped) { for (caf_shmem_team_t t = caf_current_team; t; t = t->parent) - leave_team (t, stopped); + leave_team (t->u.image_info, stopped); for (caf_shmem_team_t t = caf_teams_formed; t; t = t->parent) - leave_team (t, stopped); + leave_team (t->u.image_info, stopped); +} + +void +register_team (caf_shmem_team_t team) +{ + struct shmem_image_info *info = team->u.image_info; + const shared_mem_ptr self = AS_SHMPTR ((void *) info, local->sm); + ptrdiff_t head; + + /* Push without taking a lock, so that an image killed in the middle of it + cannot block the supervisor. */ + head = __atomic_load_n (&this_image.supervisor->teams.offset, + __ATOMIC_ACQUIRE); + do + info->next_team.offset = head; + while (!__atomic_compare_exchange_n (&this_image.supervisor->teams.offset, + &head, self.offset, false, + __ATOMIC_RELEASE, __ATOMIC_ACQUIRE)); +} + +void +update_registered_teams (void) +{ + ptrdiff_t off = __atomic_load_n (&this_image.supervisor->teams.offset, + __ATOMIC_ACQUIRE); + + while (off != SHMPTR_NULL.offset) + { + struct shmem_image_info *info + = SHMPTR_AS (struct shmem_image_info *, ((shared_mem_ptr) {off}), + &local->sm); + + /* A terminated image is dropped from the count, so that the others can + complete their barriers, but a collective over a fixed set of images + can no longer be completed. */ + leave_team (info, false); + off = __atomic_load_n (&info->next_team.offset, __ATOMIC_ACQUIRE); + } } int diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h index 3b0c3b6aa225..b87fc6f87d12 100644 --- a/libgfortran/caf/shmem/teams_mgmt.h +++ b/libgfortran/caf/shmem/teams_mgmt.h @@ -62,6 +62,8 @@ struct caf_shmem_team this is checked against the global number and the image_count and image_map is updated. */ int num_term_images; + /* The next team in the supervisor's list of teams. */ + shared_mem_ptr next_team; memid lastmemid; int image_map[]; } *image_info; @@ -86,6 +88,17 @@ extern caf_shmem_team_t caf_teams_formed; void update_teams_images (caf_shmem_team_t); +/* Make TEAM known to the supervisor. To be called once per team, by the + image that created it. */ + +void register_team (caf_shmem_team_t); + +/* Drop the images that terminated from the barriers of every team known to + the supervisor. For the supervisor, which has no access to the teams an + image was a member of. */ + +void update_registered_teams (void); + /* 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. When STOPPED, image control
