https://gcc.gnu.org/g:5d74e9640ebebb10abab61cfd20631dbe6a97dcc
commit r17-5127-g5d74e9640ebebb10abab61cfd20631dbe6a97dcc Author: Jerry DeLisle <[email protected]> Date: Mon Oct 5 18:13:33 2026 -0700 libgfortran: [PR127837] Set END TEAM STAT= for stopped and failed images With caf_shmem, END TEAM always returned STAT=0 because _gfortran_caf_end_team synchronized with sync_team, which does not report stopped or failed images. Without STAT= such an image did not cause error termination either, as F2023 11.7.11 requires. END TEAM now takes the number of terminated images from the barrier round and runs TEAM_HEALTH_CHECK on the ended team after deallocating its coarrays; counter_barrier_wait gains a TERMINATED argument for this. Existing tests that end a team containing a stopped or failed image now give END TEAM a STAT= variable. Assisted-by: Claude Opus 5.5 PR libfortran/127837 libgfortran/ChangeLog: * caf/shmem.c (_gfortran_caf_end_team): Wait with counter_barrier_wait and set STAT= with TEAM_HEALTH_CHECK when an image of the team stopped or failed. Do not pass STAT= to _gfortran_caf_deregister. * caf/shmem/counter_barrier.c (counter_barrier_wait): Add TERMINATED argument. * caf/shmem/counter_barrier.h (counter_barrier_wait): Likewise. * caf/shmem/sync.c (sync_team): Update call. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/signal_team_1.f90: Add STAT= to END TEAM. * gfortran.dg/coarray/stop_end_team_1.f90: Likewise and check it. * gfortran.dg/coarray/stop_sync_team_1.f90: Likewise. * gfortran.dg/coarray/end_team_stat_1.f90: New test. * gfortran.dg/coarray/end_team_stat_2.f90: New test. Diff: --- .../gfortran.dg/coarray/end_team_stat_1.f90 | 42 ++++++++++++++++++++++ .../gfortran.dg/coarray/end_team_stat_2.f90 | 18 ++++++++++ .../gfortran.dg/coarray/signal_team_1.f90 | 2 +- .../gfortran.dg/coarray/stop_end_team_1.f90 | 3 +- .../gfortran.dg/coarray/stop_sync_team_1.f90 | 4 ++- libgfortran/caf/shmem.c | 17 +++++---- libgfortran/caf/shmem/counter_barrier.c | 4 +-- libgfortran/caf/shmem/counter_barrier.h | 10 +++--- libgfortran/caf/shmem/sync.c | 2 +- 9 files changed, 85 insertions(+), 17 deletions(-) diff --git a/gcc/testsuite/gfortran.dg/coarray/end_team_stat_1.f90 b/gcc/testsuite/gfortran.dg/coarray/end_team_stat_1.f90 new file mode 100644 index 000000000000..1a3fdafefe24 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/end_team_stat_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } } +! +! END TEAM (STAT=) reports a stopped or failed image of the team it ends, +! not one of a sibling team, and still deallocates the team's coarrays. + +program end_team_stat_1 + use iso_fortran_env, only : team_type, stat_stopped_image, stat_failed_image + implicit none + type(team_type) :: t + integer, allocatable :: a[:] + integer :: me, st + character(len=40) :: msg + + if (num_images () < 6) stop + me = mod (this_image () - 1, 3) + 1 + form team (me, t) + + change team (t) + msg = "unchanged" + end team (stat=st, errmsg=msg) + if (st /= 0 .or. msg /= "unchanged") error stop 1 + + change team (t) + allocate (a[*]) + if (this_image () == num_images ()) then + if (me == 1) stop + if (me == 2) fail image + end if + st = -1 + msg = "unchanged" + end team (stat=st, errmsg=msg) + if (allocated (a)) error stop 2 + select case (me) + case (1) + if (st /= stat_stopped_image .or. msg == "unchanged") error stop 3 + case (2) + if (st /= stat_failed_image .or. msg == "unchanged") error stop 4 + case (3) + if (st /= 0 .or. msg /= "unchanged") error stop 5 + end select +end program end_team_stat_1 diff --git a/gcc/testsuite/gfortran.dg/coarray/end_team_stat_2.f90 b/gcc/testsuite/gfortran.dg/coarray/end_team_stat_2.f90 new file mode 100644 index 000000000000..600d4058448e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/end_team_stat_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } } +! { dg-shouldfail "END TEAM without STAT= in a team with a stopped image" } +! +! END TEAM without STAT= in a team with a stopped image is error +! termination. + +program end_team_stat_2 + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: t + + if (num_images () < 2) error stop + form team (1, t) + change team (t) + if (this_image () == num_images ()) stop + end team +end program end_team_stat_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 index 958801a7fdaa..bcce79c939e3 100644 --- a/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90 @@ -22,5 +22,5 @@ program signal_team_1 if (st == stat_failed_image) exit end do if (num_images () > 1 .and. st /= stat_failed_image) error stop "not reported" - end team + end team (stat=st) end program signal_team_1 diff --git a/gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90 index 79e7d246f577..3b5fe656ff52 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90 @@ -21,7 +21,8 @@ program stop_end_team_1 if (st /= 0 .and. st /= stat_stopped_image) error stop 1 end do end if - end team + end team (stat=st) + if (me == 1 .and. num_images () > 2 .and. st /= stat_stopped_image) error stop 3 st = -1 sync all (stat=st) if (num_images () > 2 .and. st /= stat_stopped_image) error stop 2 diff --git a/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90 index 9eba00e7b102..a3c9106d35de 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90 @@ -28,5 +28,7 @@ program stop_sync_team_1 sync team (get_team (), stat=st) if (me == 2 .and. st /= 0) error stop 3 if (me == 1 .and. st /= stat_stopped_image) error stop 4 - end team + end team (stat=st) + if (me == 2 .and. st /= 0) error stop 5 + if (me == 1 .and. st /= stat_stopped_image) error stop 6 end program stop_sync_team_1 diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c index 7fb23f05e6c3..014a26e9c9e8 100644 --- a/libgfortran/caf/shmem.c +++ b/libgfortran/caf/shmem.c @@ -1899,26 +1899,31 @@ void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len) { caf_shmem_team_t t = caf_current_team; - - if (stat) - *stat = 0; + int terminated; caf_current_team = caf_current_team->parent; next_memid = t->parent_teams_last_active_memid; - sync_team (t); + /* The active images synchronize even with a stopped image, unlike in + SYNC ALL (F2023 11.7.11). */ + counter_barrier_wait (&t->u.image_info->image_count, &terminated); for (struct coarray_allocated *ca = t->allocated; ca;) { struct coarray_allocated *nca = ca->next; _gfortran_caf_deregister ((caf_token_t *) &ca->token, - CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, - errmsg, errmsg_len); + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, NULL, + NULL, 0); free (ca); ca = nca; } t->allocated = NULL; t->parent = caf_teams_formed; caf_teams_formed = t; + + if (terminated) + TEAM_HEALTH_CHECK (t, stat, errmsg, errmsg_len); + else if (stat) + *stat = 0; } void diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c index 1a30e45dda70..bf3a5fbb9d9d 100644 --- a/libgfortran/caf/shmem/counter_barrier.c +++ b/libgfortran/caf/shmem/counter_barrier.c @@ -108,10 +108,10 @@ wait_round (counter_barrier *b, bool abortable, int *terminated) } void -counter_barrier_wait (counter_barrier *b) +counter_barrier_wait (counter_barrier *b, int *terminated) { lock_counter_barrier (b); - while (!wait_round (b, false, NULL)) + while (!wait_round (b, false, terminated)) ; unlock_counter_barrier (b); } diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h index 2eb886545b16..110cd71d76b2 100644 --- a/libgfortran/caf/shmem/counter_barrier.h +++ b/libgfortran/caf/shmem/counter_barrier.h @@ -88,14 +88,14 @@ void counter_barrier_init_add (counter_barrier *, int); int counter_barrier_get_count (counter_barrier *); /* Wait for the count in the barrier drop to or below 0. When the round is - aborted, take part in the next one. */ + aborted, take part in the next one. 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. */ -void counter_barrier_wait (counter_barrier *); +void counter_barrier_wait (counter_barrier *, int *terminated); /* Like counter_barrier_wait, but return false without waiting when the - 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. */ + barrier is aborting, or when the round is aborted. */ bool counter_barrier_wait_abortable (counter_barrier *, int *terminated); diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c index e3041a3c1287..4245c155f14d 100644 --- a/libgfortran/caf/shmem/sync.c +++ b/libgfortran/caf/shmem/sync.c @@ -175,7 +175,7 @@ sync_all (int *terminated) void sync_team (caf_shmem_team_t team) { - counter_barrier_wait (&team->u.image_info->image_count); + counter_barrier_wait (&team->u.image_info->image_count, NULL); } bool
