See attached patch 3 of 3.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
libgfortran: [PR127347] caf_shmem: fix STAT= for stopped
images
Image control statements and collective subroutines did not follow
F2023 when an image of the team had stopped.
Collective subroutines blocked forever. They now report
STAT_STOPPED_IMAGE, or STAT_FAILED_IMAGE, when the current team
contains a terminated image (F2023 16.6), and a collective already
running gives up with an error instead of blocking.
STAT= was classified with the program-wide counts of stopped and
failed images, so an image that stopped in one team made SYNC ALL in a
sibling team report STAT_STOPPED_IMAGE. It is now classified over the
images involved in the statement, and SYNC TEAM reports them at all.
SYNC ALL and SYNC TEAM with a stopped image still synchronized the
remaining images, although F2023 11.7.11 gives them the effect of SYNC
MEMORY, so a conforming program could deadlock. This needs the team
barrier to decide consistently which images synchronized: its rounds
are now numbered, and a round with an arrival from SYNC ALL, SYNC TEAM
or a collective subroutine is aborted rather than completed once a
stopped image exists. Images waiting in END TEAM, CHANGE TEAM or at
program end take part in the next round instead.
Not addressed: an image that crashes while others wait in the barrier
of a team other than the initial team can still block them, and END
TEAM does not set STAT=.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_sync_all, _gfortran_caf_sync_team):
Have the effect of SYNC MEMORY with a stopped image. Check the
images of the team synchronized.
(_gfortran_caf_sync_images): Check the images synchronized. Fix
the format of the duplicate image error.
(mark_stopped): Wake the images in a collective subroutine.
(_gfortran_caf_co_broadcast, _gfortran_caf_co_sum)
(_gfortran_caf_co_min, _gfortran_caf_co_max)
(_gfortran_caf_co_reduce): Report terminated images of the team.
* caf/shmem/collective_subroutine.c (collsub_images_terminated): New
function.
(collsub_sync): Give up when an image of the team terminated.
* caf/shmem/counter_barrier.c (counter_barrier_init): Initialize the
new fields.
(next_round): New function.
(counter_barrier_wait_recheck): Add abortable argument. Number the
rounds and abort a round with an abortable arrival when the recheck
reports so.
(counter_barrier_wait): Adjust.
* caf/shmem/counter_barrier.h (counter_barrier): Make
curr_wait_group a round number. Add aborted_round and
abortable_arrivals.
(counter_barrier_wait_recheck): Add abortable argument.
* caf/shmem/supervisor.c (ensure_shmem_initialization): Record the
initial team's collective barrier.
(wake_barrier): New function.
(supervisor_main_loop): Use it for the initial team's barriers.
* caf/shmem/supervisor.h (supervisor): Add
initial_team_collsub_barrier.
* caf/shmem/sync.c (sync_all): Return whether the images were
synchronized.
(sync_team): Take part in the next round when a round is aborted.
(sync_team_unless_stopped): New function.
* caf/shmem/sync.h (sync_all): Adjust.
(sync_team_unless_stopped): Declare.
* caf/shmem/teams_mgmt.c (count_images, team_terminated_images)
(update_and_check_stopped): New functions.
(update_teams_images_locked): Take the team.
(update_teams_images): Wake the images waiting in the barrier.
(check_health): Classify the given images. Return the stat value.
* caf/shmem/teams_mgmt.h (team_terminated_images)
(update_and_check_stopped): Declare.
(update_teams_images_locked, check_health): Adjust.
(TEAM_HEALTH_CHECK): New macro.
(HEALTH_CHECK): Use it.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/stop_sync_1.f90: Check STAT=.
* gfortran.dg/coarray/collective_stopped_1.f90: New test.
* gfortran.dg/coarray/stop_end_team_1.f90: New test.
* gfortran.dg/coarray/stop_sync_team_1.f90: New test.
* gfortran.dg/coarray/sync_memory_stopped_1.f90: New test.
---From 676adab87ad813b86d487b00c868bb8924852c4e Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Fri, 28 Aug 2026 17:05:15 -0700
Subject: [PATCH 3/3] libgfortran: [PR127347] caf_shmem: fix STAT= for stopped
images
Image control statements and collective subroutines did not follow
F2023 when an image of the team had stopped.
Collective subroutines blocked forever. They now report
STAT_STOPPED_IMAGE, or STAT_FAILED_IMAGE, when the current team
contains a terminated image (F2023 16.6), and a collective already
running gives up with an error instead of blocking.
STAT= was classified with the program-wide counts of stopped and
failed images, so an image that stopped in one team made SYNC ALL in a
sibling team report STAT_STOPPED_IMAGE. It is now classified over the
images involved in the statement, and SYNC TEAM reports them at all.
SYNC ALL and SYNC TEAM with a stopped image still synchronized the
remaining images, although F2023 11.7.11 gives them the effect of SYNC
MEMORY, so a conforming program could deadlock. This needs the team
barrier to decide consistently which images synchronized: its rounds
are now numbered, and a round with an arrival from SYNC ALL, SYNC TEAM
or a collective subroutine is aborted rather than completed once a
stopped image exists. Images waiting in END TEAM, CHANGE TEAM or at
program end take part in the next round instead.
Not addressed: an image that crashes while others wait in the barrier
of a team other than the initial team can still block them, and END
TEAM does not set STAT=.
Assisted-by: Claude Opus 5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_sync_all, _gfortran_caf_sync_team):
Have the effect of SYNC MEMORY with a stopped image. Check the
images of the team synchronized.
(_gfortran_caf_sync_images): Check the images synchronized. Fix
the format of the duplicate image error.
(mark_stopped): Wake the images in a collective subroutine.
(_gfortran_caf_co_broadcast, _gfortran_caf_co_sum)
(_gfortran_caf_co_min, _gfortran_caf_co_max)
(_gfortran_caf_co_reduce): Report terminated images of the team.
* caf/shmem/collective_subroutine.c (collsub_images_terminated): New
function.
(collsub_sync): Give up when an image of the team terminated.
* caf/shmem/counter_barrier.c (counter_barrier_init): Initialize the
new fields.
(next_round): New function.
(counter_barrier_wait_recheck): Add abortable argument. Number the
rounds and abort a round with an abortable arrival when the recheck
reports so.
(counter_barrier_wait): Adjust.
* caf/shmem/counter_barrier.h (counter_barrier): Make
curr_wait_group a round number. Add aborted_round and
abortable_arrivals.
(counter_barrier_wait_recheck): Add abortable argument.
* caf/shmem/supervisor.c (ensure_shmem_initialization): Record the
initial team's collective barrier.
(wake_barrier): New function.
(supervisor_main_loop): Use it for the initial team's barriers.
* caf/shmem/supervisor.h (supervisor): Add
initial_team_collsub_barrier.
* caf/shmem/sync.c (sync_all): Return whether the images were
synchronized.
(sync_team): Take part in the next round when a round is aborted.
(sync_team_unless_stopped): New function.
* caf/shmem/sync.h (sync_all): Adjust.
(sync_team_unless_stopped): Declare.
* caf/shmem/teams_mgmt.c (count_images, team_terminated_images)
(update_and_check_stopped): New functions.
(update_teams_images_locked): Take the team.
(update_teams_images): Wake the images waiting in the barrier.
(check_health): Classify the given images. Return the stat value.
* caf/shmem/teams_mgmt.h (team_terminated_images)
(update_and_check_stopped): Declare.
(update_teams_images_locked, check_health): Adjust.
(TEAM_HEALTH_CHECK): New macro.
(HEALTH_CHECK): Use it.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/stop_sync_1.f90: Check STAT=.
* gfortran.dg/coarray/collective_stopped_1.f90: New test.
* gfortran.dg/coarray/stop_end_team_1.f90: New test.
* gfortran.dg/coarray/stop_sync_team_1.f90: New test.
* gfortran.dg/coarray/sync_memory_stopped_1.f90: New test.
---
.../coarray/collective_stopped_1.f90 | 33 ++++++
.../gfortran.dg/coarray/stop_end_team_1.f90 | 28 +++++
.../gfortran.dg/coarray/stop_sync_1.f90 | 4 +-
.../gfortran.dg/coarray/stop_sync_team_1.f90 | 32 ++++++
.../coarray/sync_memory_stopped_1.f90 | 25 +++++
libgfortran/caf/shmem.c | 39 ++++++-
libgfortran/caf/shmem/collective_subroutine.c | 22 +++-
libgfortran/caf/shmem/counter_barrier.c | 71 ++++++++----
libgfortran/caf/shmem/counter_barrier.h | 29 +++--
libgfortran/caf/shmem/supervisor.c | 39 +++++--
libgfortran/caf/shmem/supervisor.h | 5 +-
libgfortran/caf/shmem/sync.c | 19 +++-
libgfortran/caf/shmem/sync.h | 9 +-
libgfortran/caf/shmem/teams_mgmt.c | 104 ++++++++++++------
libgfortran/caf/shmem/teams_mgmt.h | 30 ++++-
15 files changed, 392 insertions(+), 97 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/collective_stopped_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_memory_stopped_1.f90
diff --git a/gcc/testsuite/gfortran.dg/coarray/collective_stopped_1.f90 b/gcc/testsuite/gfortran.dg/coarray/collective_stopped_1.f90
new file mode 100644
index 00000000000..b1eae226279
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/collective_stopped_1.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! A collective subroutine has to report an image that terminated normally
+! through stat= instead of blocking forever.
+
+program collective_stopped_1
+ use iso_fortran_env, only : stat_stopped_image
+ implicit none
+ integer :: st, val
+
+ sync all
+ if (num_images () > 1 .and. this_image () == num_images ()) stop
+
+ st = 0
+ sync all (stat=st)
+
+ val = this_image ()
+ st = 0
+ call co_sum (val, stat=st)
+ if (num_images () > 1) then
+ if (st /= stat_stopped_image) error stop "co_sum missed the stopped image"
+ else
+ if (st /= 0) error stop "co_sum failed"
+ end if
+
+ st = 0
+ call co_broadcast (val, 1, stat=st)
+ if (num_images () > 1) then
+ if (st /= stat_stopped_image) error stop "co_broadcast missed the stopped image"
+ else
+ if (st /= 0) error stop "co_broadcast failed"
+ end if
+end program collective_stopped_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
new file mode 100644
index 00000000000..79e7d246f57
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/stop_end_team_1.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } }
+!
+! In a team with a stopped image, SYNC ALL (STAT=) on some images must not
+! pair with END TEAM on the others.
+
+program stop_end_team_1
+ use iso_fortran_env, only : team_type, stat_stopped_image
+ implicit none
+ type(team_type) :: t
+ integer :: me, st, k
+
+ me = 2 - mod (this_image (), 2)
+ form team (me, t)
+ change team (t)
+ sync all
+ if (me == 1 .and. num_images () > 1 .and. this_image () == num_images ()) stop
+ if (me == 1 .and. mod (this_image (), 2) == 0) then
+ do k = 1, 3
+ sync all (stat=st)
+ if (st /= 0 .and. st /= stat_stopped_image) error stop 1
+ end do
+ end if
+ end team
+ st = -1
+ sync all (stat=st)
+ if (num_images () > 2 .and. st /= stat_stopped_image) error stop 2
+end program stop_end_team_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
index cb41610aaf9..ee2d8426ba4 100644
--- a/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/stop_sync_1.f90
@@ -1,9 +1,10 @@
! { dg-do run }
!
! A normal STOP on one image must not block the surviving images in the
-! SYNC ALL statements that follow.
+! SYNC ALL statements that follow, which report STAT_STOPPED_IMAGE.
program stop_sync_1
+ use iso_fortran_env, only : stat_stopped_image
implicit none
integer :: i, st
@@ -14,4 +15,5 @@ program stop_sync_1
st = 0
sync all (stat=st)
end do
+ if (num_images () > 1 .and. st /= stat_stopped_image) error stop 1
end program stop_sync_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90
new file mode 100644
index 00000000000..9eba00e7b10
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/stop_sync_team_1.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-skip-if "CHANGE TEAM needs a coarray library" { *-*-* } { "-fcoarray=single" } { "" } }
+!
+! An image stopping in one team is a stopped image for SYNC ALL and SYNC
+! TEAM in that team only, not in its sibling team.
+
+program stop_sync_team_1
+ use iso_fortran_env, only : team_type, stat_stopped_image
+ implicit none
+ type(team_type) :: t
+ integer :: i, st, me
+
+ if (num_images () < 4) stop
+ me = 2 - mod (this_image (), 2)
+ form team (me, t)
+ change team (t)
+ sync all
+ if (me == 1 .and. this_image () == num_images ()) stop
+
+ do i = 1, 5
+ st = -1
+ sync all (stat=st)
+ if (me == 2 .and. st /= 0) error stop 1
+ end do
+ if (me == 1 .and. st /= stat_stopped_image) error stop 2
+
+ st = -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 program stop_sync_team_1
diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_memory_stopped_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_memory_stopped_1.f90
new file mode 100644
index 00000000000..dd400fd5911
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/sync_memory_stopped_1.f90
@@ -0,0 +1,25 @@
+! { dg-do run }
+!
+! SYNC ALL (STAT=) with a stopped image in the team has the effect of
+! SYNC MEMORY: it must not wait for the other images (F2023 11.7.11).
+
+program sync_memory_stopped_1
+ use iso_fortran_env, only : stat_stopped_image
+ implicit none
+ integer :: s
+
+ if (num_images () < 3) stop
+ sync all
+ if (this_image () == 3) stop
+ do while (image_status (3) /= stat_stopped_image)
+ end do
+ s = -1
+ if (this_image () == 1) then
+ sync all (stat=s)
+ sync images (2)
+ else if (this_image () == 2) then
+ sync images (1)
+ sync all (stat=s)
+ end if
+ if (this_image () <= 2 .and. s /= stat_stopped_image) error stop 1
+end program sync_memory_stopped_1
diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index 5c92c13d328..dbb96f4a2c3 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -483,7 +483,9 @@ _gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len)
__asm__ __volatile__ ("":::"memory");
HEALTH_CHECK (stat, errmsg, errmsg_len);
CHECK_TEAM_INTEGRITY (caf_current_team);
- sync_all ();
+ /* With a stopped image, SYNC ALL only has the effect of SYNC MEMORY. */
+ if (!sync_all ())
+ HEALTH_CHECK (stat, errmsg, errmsg_len);
}
@@ -543,7 +545,7 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
if (mapped_images[c] == mapped_images[i])
{
caf_internal_error ("SYNC IMAGES: Duplicate image %d in "
- "images at position %d and &d.",
+ "images at position %d and %d.",
stat, errmsg, errmsg_len, images[c],
i + 1, c + 1);
/* There is no official error code for this, but 3 is what
@@ -565,7 +567,10 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
__asm__ __volatile__ ("" ::: "memory");
sync_table (&local->si, mapped_images, count);
- HEALTH_CHECK (stat, errmsg, errmsg_len);
+ if (count > 0)
+ check_health (mapped_images, count, stat, errmsg, errmsg_len);
+ else
+ HEALTH_CHECK (stat, errmsg, errmsg_len);
}
extern void _gfortran_report_exception (void);
@@ -587,9 +592,13 @@ mark_stopped (void)
atomic_fetch_add (&this_image.supervisor->finished_images, 1);
}
- /* Drop this image from the barriers of the teams it is a member of. */
+ /* Drop this image from the barriers of the teams it is a member of and wake
+ the images waiting in a collective subroutine. */
for (caf_shmem_team_t t = caf_current_team; t; t = t->parent)
- update_teams_images (t);
+ {
+ update_teams_images (t);
+ caf_shmem_cond_broadcast (&t->u.image_info->collsub.barrier.cond);
+ }
}
/* Tell the supervisor that this image error stopped, so that it can terminate
@@ -850,6 +859,9 @@ _gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat,
if (stat)
*stat = 0;
+ if (HEALTH_CHECK (stat, errmsg, errmsg_len))
+ return;
+
if (!check_map_team (&mapped_index, &this_image_index, source_image, NULL,
NULL, stat))
return;
@@ -945,6 +957,9 @@ _gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat,
if (stat)
*stat = 0;
+ if (HEALTH_CHECK (stat, errmsg, errmsg_len))
+ return;
+
/* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */
if (result_image
&& !check_map_team (&mapped_index, &this_image_index, result_image, NULL,
@@ -967,6 +982,9 @@ _gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat,
if (stat)
*stat = 0;
+
+ if (HEALTH_CHECK (stat, errmsg, errmsg_len))
+ return;
/* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */
if (result_image
&& !check_map_team (&mapped_index, &this_image_index, result_image, NULL,
@@ -989,6 +1007,9 @@ _gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat,
if (stat)
*stat = 0;
+
+ if (HEALTH_CHECK (stat, errmsg, errmsg_len))
+ return;
/* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */
if (result_image
&& !check_map_team (&mapped_index, &this_image_index, result_image, NULL,
@@ -1011,6 +1032,9 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *),
if (stat)
*stat = 0;
+ if (HEALTH_CHECK (stat, errmsg, errmsg_len))
+ return;
+
/* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */
if (result_image
&& !check_map_team (&mapped_index, &this_image_index, result_image, NULL,
@@ -1939,7 +1963,10 @@ _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg,
return;
}
- sync_team (team_to_sync);
+ 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))
+ TEAM_HEALTH_CHECK (team_to_sync, stat, errmsg, errmsg_len);
}
int
diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c
index 01389b18b0a..412bcfa5dbc 100644
--- a/libgfortran/caf/shmem/collective_subroutine.c
+++ b/libgfortran/caf/shmem/collective_subroutine.c
@@ -22,6 +22,7 @@ a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
<http://www.gnu.org/licenses/>. */
+#include "../caf_error.h"
#include "collective_subroutine.h"
#include "supervisor.h"
#include "teams_mgmt.h"
@@ -218,13 +219,32 @@ get_collsub_buf (size_t size)
return ret;
}
+/* Give up on the collective's barrier as soon as an image of the team has
+ terminated. The reduction is laid out over a fixed set of images, so it
+ cannot be completed with fewer of them. */
+
+static int
+collsub_images_terminated (void *team)
+{
+ if (!this_image.supervisor->finished_images
+ && !this_image.supervisor->failed_images)
+ return 0;
+
+ return team_terminated_images ((caf_shmem_team_t) team) != 0;
+}
+
/* This function syncs all images with one another. It will only return once
all images have called it. */
static void
collsub_sync (void)
{
- counter_barrier_wait (&caf_current_team->u.image_info->collsub.barrier);
+ counter_barrier *barrier = &caf_current_team->u.image_info->collsub.barrier;
+
+ if (!counter_barrier_wait_recheck (barrier, collsub_images_terminated,
+ caf_current_team, true))
+ caf_runtime_error ("Image terminated while executing a collective "
+ "subroutine");
}
typedef void *(*red_op) (void *, void *);
diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c
index 0e583eecb98..23935d7344a 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -48,50 +48,73 @@ unlock_counter_barrier (counter_barrier *b)
void
counter_barrier_init (counter_barrier *b, int val)
{
- *b = (counter_barrier) {CAF_SHMEM_MUTEX_INITIALIZER,
- CAF_SHMEM_COND_INITIALIZER, val, 0, val};
+ *b = (counter_barrier) {.mutex = CAF_SHMEM_MUTEX_INITIALIZER,
+ .cond = CAF_SHMEM_COND_INITIALIZER,
+ .wait_count = val,
+ .curr_wait_group = 1,
+ .aborted_round = 0,
+ .abortable_arrivals = 0,
+ .count = val};
initialize_shared_condition (&b->cond, val);
initialize_shared_mutex (&b->mutex);
}
-void
+/* Start the next round of the barrier and wake the images waiting in the
+ current one. */
+
+static void
+next_round (counter_barrier *b, bool abort)
+{
+ if (abort)
+ b->aborted_round = b->curr_wait_group;
+ ++b->curr_wait_group;
+ b->wait_count = b->count;
+ b->abortable_arrivals = 0;
+ caf_shmem_cond_broadcast (&b->cond);
+}
+
+bool
counter_barrier_wait_recheck (counter_barrier *b,
- counter_barrier_recheck recheck, void *data)
+ counter_barrier_recheck recheck, void *data,
+ bool abortable)
{
- int wait_group_beginning;
+ uint64_t round;
+ bool completed;
lock_counter_barrier (b);
- /* Re-check before blocking, so that a terminating image that adjusted the
- count before this image took the lock is not waited for. */
- if (recheck)
- recheck (data);
- wait_group_beginning = b->curr_wait_group;
-
- if ((--b->wait_count) <= 0)
- caf_shmem_cond_broadcast (&b->cond);
- else
+ round = b->curr_wait_group;
+ if (recheck && recheck (data) && abortable)
{
- while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
- {
- caf_shmem_cond_wait (&b->cond, &b->mutex);
- if (recheck)
- recheck (data);
- }
+ if (b->abortable_arrivals)
+ next_round (b, true);
+ unlock_counter_barrier (b);
+ return false;
}
- if (b->wait_count <= 0)
+ if (abortable)
+ ++b->abortable_arrivals;
+ --b->wait_count;
+ while (b->wait_count > 0 && b->curr_wait_group == round)
{
- b->curr_wait_group = !wait_group_beginning;
- b->wait_count = b->count;
+ caf_shmem_cond_wait (&b->cond, &b->mutex);
+ if (b->curr_wait_group == round && b->abortable_arrivals && recheck
+ && recheck (data))
+ next_round (b, true);
}
+ /* The last image to arrive ends the round. */
+ if (b->curr_wait_group == round)
+ next_round (b, b->abortable_arrivals && recheck && recheck (data));
+
+ completed = b->aborted_round != round;
unlock_counter_barrier (b);
+ return completed;
}
void
counter_barrier_wait (counter_barrier *b)
{
- counter_barrier_wait_recheck (b, NULL, NULL);
+ counter_barrier_wait_recheck (b, NULL, NULL, false);
}
static inline void
diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h
index 75cf3e2c41c..ac83c9de4fc 100644
--- a/libgfortran/caf/shmem/counter_barrier.h
+++ b/libgfortran/caf/shmem/counter_barrier.h
@@ -27,6 +27,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "thread_support.h"
+#include <stdbool.h>
+#include <stdint.h>
+
/* Usable as counter barrier and as waitable counter.
This "class" allows to sync all images acting as a barrier. For this the
counter_barrier is to be initialized by the number of images and then later
@@ -44,7 +47,13 @@ typedef struct
caf_shmem_mutex mutex;
caf_shmem_condvar cond;
volatile int wait_count;
- volatile int curr_wait_group;
+ /* The number of the current round of the barrier, and of the last round
+ that was aborted. */
+ volatile uint64_t curr_wait_group;
+ volatile uint64_t aborted_round;
+ /* The number of images in the current round that asked for it to be
+ aborted when RECHECK reports so. */
+ volatile int abortable_arrivals;
volatile int count;
} counter_barrier;
@@ -73,19 +82,23 @@ void counter_barrier_init_add (counter_barrier *, int);
int counter_barrier_get_count (counter_barrier *);
-/* Called with the barrier's mutex held every time a waiting image wakes up.
- It allows the caller to adjust the barrier's count, e.g. when images have
- terminated in the meantime. */
+/* Called with the barrier's mutex held before an image blocks, every time a
+ waiting image wakes up and before a round completes. It allows the caller
+ to adjust the barrier's count, e.g. when images have terminated in the
+ meantime. Returns non-zero when a round with an abortable arrival is to be
+ aborted instead of completed. */
-typedef void (*counter_barrier_recheck) (void *);
+typedef int (*counter_barrier_recheck) (void *);
/* Wait for the count in the barrier drop to or below 0. */
void counter_barrier_wait (counter_barrier *);
-/* Like counter_barrier_wait, but call RECHECK with DATA on every wake up. */
+/* Like counter_barrier_wait, but call RECHECK with DATA. An ABORTABLE
+ arrival does not wait when RECHECK reports so, and the round it is in is
+ aborted for all its images. Returns false, when the round was aborted. */
-void counter_barrier_wait_recheck (counter_barrier *, counter_barrier_recheck,
- void *);
+bool counter_barrier_wait_recheck (counter_barrier *, counter_barrier_recheck,
+ void *, bool abortable);
#endif
diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c
index c5b6209b800..c5022f3380a 100644
--- a/libgfortran/caf/shmem/supervisor.c
+++ b/libgfortran/caf/shmem/supervisor.c
@@ -236,6 +236,9 @@ ensure_shmem_initialization (void)
collsub_init_supervisor (&caf_initial_team->u.image_info->collsub,
alloc_get_allocator (&local->ai),
local->total_num_images);
+ this_image.supervisor->initial_team_collsub_barrier = AS_SHMPTR (
+ (void *) &caf_initial_team->u.image_info->collsub.barrier,
+ local->sm);
caf_initial_team->u.image_info->team_parent_id = 0;
caf_initial_team->u.image_info->team_id = -1;
caf_initial_team->u.image_info->image_map_size
@@ -256,6 +259,7 @@ ensure_shmem_initialization (void)
counter_barrier_init (&this_image.supervisor->num_active_images,
local->total_num_images);
this_image.supervisor->initial_team_barrier = SHMPTR_NULL;
+ this_image.supervisor->initial_team_collsub_barrier = SHMPTR_NULL;
alloc_init_supervisor (&local->ai, &local->sm);
sync_init_supervisor (&local->si, &local->ai);
}
@@ -303,6 +307,24 @@ startWorker (image *im __attribute__ ((unused)),
return true;
}
+/* Wake the images waiting in the given barrier. Taking the lock ensures that
+ an image about to block sees the status of the terminated image instead of
+ the wake up. */
+
+static void
+wake_barrier (shared_mem_ptr barrier)
+{
+ counter_barrier *b;
+
+ if (SHMPTR_IS_NULL (barrier))
+ return;
+
+ b = SHMPTR_AS (counter_barrier *, barrier, &local->sm);
+ caf_shmem_mutex_lock (&b->mutex);
+ caf_shmem_cond_broadcast (&b->cond);
+ caf_shmem_mutex_unlock (&b->mutex);
+}
+
#ifdef HAVE_FORK
static void
kill_all_images (supervisor *m)
@@ -494,18 +516,11 @@ supervisor_main_loop (int *argc __attribute__ ((unused)),
caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
m->sync_shared.sync_images_cond_vars,
&local->sm)[j]);
- /* Trigger images waiting in the initial team's barrier, e.g. in
- SYNC ALL, to re-evaluate the number of participating images. */
- if (!SHMPTR_IS_NULL (m->initial_team_barrier))
- {
- counter_barrier *b = SHMPTR_AS (counter_barrier *,
- m->initial_team_barrier, &local->sm);
- /* Under the lock, so that an image about to block sees the status
- of the terminated image instead of the wake up. */
- caf_shmem_mutex_lock (&b->mutex);
- caf_shmem_cond_broadcast (&b->cond);
- caf_shmem_mutex_unlock (&b->mutex);
- }
+ /* Trigger images waiting in the initial team's barriers, e.g. in
+ SYNC ALL or in a collective subroutine, to re-evaluate the images
+ still participating. */
+ wake_barrier (m->initial_team_barrier);
+ wake_barrier (m->initial_team_collsub_barrier);
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/supervisor.h b/libgfortran/caf/shmem/supervisor.h
index f859bd41256..82c9204f3c3 100644
--- a/libgfortran/caf/shmem/supervisor.h
+++ b/libgfortran/caf/shmem/supervisor.h
@@ -62,9 +62,10 @@ typedef struct supervisor
atomic_int failed_images;
atomic_int finished_images;
counter_barrier num_active_images;
- /* The initial team's image_count barrier, used by the supervisor to wake
- images waiting in it when an image has terminated. */
+ /* The initial team's barriers, used by the supervisor to wake images waiting
+ in them when an image has terminated. */
shared_mem_ptr initial_team_barrier;
+ shared_mem_ptr initial_team_collsub_barrier;
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 3d03cd67152..ef63de528e8 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -147,19 +147,28 @@ sync_table (sync_t *si, int *images, int size)
unlock_table (si);
}
-void
+bool
sync_all (void)
{
- sync_team (caf_current_team);
+ return sync_team_unless_stopped (caf_current_team);
}
void
sync_team (caf_shmem_team_t team)
{
/* Re-evaluate the number of participating images on every wake up, so that
- images terminating while this image waits do not block it forever. */
- counter_barrier_wait_recheck (&team->u.image_info->image_count,
- update_teams_images_locked, team);
+ images terminating while this image waits do not block it forever. Take
+ part in the next round when another image aborted this one. */
+ while (!counter_barrier_wait_recheck (&team->u.image_info->image_count,
+ update_and_check_stopped, team, false))
+ ;
+}
+
+bool
+sync_team_unless_stopped (caf_shmem_team_t team)
+{
+ return counter_barrier_wait_recheck (&team->u.image_info->image_count,
+ update_and_check_stopped, team, true);
}
void
diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h
index 6f8b28d378a..0aa596c9eff 100644
--- a/libgfortran/caf/shmem/sync.h
+++ b/libgfortran/caf/shmem/sync.h
@@ -51,7 +51,10 @@ void sync_init (sync_t *, shared_memory);
void sync_init_supervisor (sync_t *, alloc *);
-void sync_all (void);
+/* Synchronize the images of the current team. Returns false without
+ synchronizing when a stopped image is a member of the team. */
+
+bool sync_all (void);
/* Prototype for circular dependency break. */
@@ -60,6 +63,10 @@ typedef struct caf_shmem_team *caf_shmem_team_t;
void sync_team (caf_shmem_team_t team);
+/* Like sync_all for TEAM. */
+
+bool sync_team_unless_stopped (caf_shmem_team_t team);
+
void sync_table (sync_t *, int *, int);
void lock_alloc_lock (sync_t *);
diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c
index 0e67a7532b5..9593e3cdfa0 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -28,26 +28,44 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
caf_shmem_team_t caf_current_team = NULL, caf_initial_team;
caf_shmem_team_t caf_teams_formed = NULL;
-void
-update_teams_images_locked (void *data)
+/* Count the images among the COUNT images in MAP that have status STATUS. */
+
+static int
+count_images (const int *map, int count, image_status status)
{
- caf_shmem_team_t team = (caf_shmem_team_t) data;
+ int i, n = 0;
+
+ for (i = 0; i < count; ++i)
+ if (this_image.supervisor->images[map[i]].status == status)
+ ++n;
+
+ return n;
+}
+
+int
+team_terminated_images (caf_shmem_team_t team)
+{
+ const int sz = team->u.image_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)
+ ++term;
+
+ return term;
+}
+void
+update_teams_images_locked (caf_shmem_team_t team)
+{
if (team->u.image_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 sz = team->u.image_info->image_map_size;
- int i, good = 0;
-
- for (i = 0; i < sz; ++i)
- if (this_image.supervisor->images[team->u.image_info->image_map[i]]
- .status
- == IMAGE_OK)
- ++good;
- team->u.image_info->num_term_images = sz - good;
+ team->u.image_info->num_term_images = team_terminated_images (team);
counter_barrier_add_locked (&team->u.image_info->image_count,
old_num
@@ -55,37 +73,57 @@ update_teams_images_locked (void *data)
}
}
+int
+update_and_check_stopped (void *data)
+{
+ caf_shmem_team_t team = (caf_shmem_team_t) data;
+
+ update_teams_images_locked (team);
+ return this_image.supervisor->finished_images
+ && count_images (team->u.image_info->image_map,
+ team->u.image_info->image_map_size, IMAGE_SUCCESS);
+}
+
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);
+ /* Wake the images waiting in the team's barrier to re-check it. */
+ caf_shmem_cond_broadcast (&team->u.image_info->image_count.cond);
caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex);
}
-void
-check_health (int *stat, char *errmsg, size_t errmsg_len)
+int
+check_health (const int *map, int count, int *stat, char *errmsg,
+ size_t errmsg_len)
{
- if (this_image.supervisor->finished_images
- || this_image.supervisor->failed_images)
+ int stopped = 0, failed = 0;
+
+ if (this_image.supervisor->finished_images)
+ stopped = count_images (map, count, IMAGE_SUCCESS);
+ if (this_image.supervisor->failed_images)
+ failed = count_images (map, count, IMAGE_FAILED);
+
+ if (stopped)
+ {
+ caf_internal_error ("Stopped images present (currently %d)", stat,
+ errmsg, errmsg_len, stopped);
+ if (stat)
+ *stat = CAF_STAT_STOPPED_IMAGE;
+ return CAF_STAT_STOPPED_IMAGE;
+ }
+
+ if (failed)
{
- if (this_image.supervisor->finished_images)
- {
- caf_internal_error ("Stopped images present (currently %d)", stat,
- errmsg, errmsg_len,
- this_image.supervisor->finished_images);
- if (stat)
- *stat = CAF_STAT_STOPPED_IMAGE;
- }
- else if (this_image.supervisor->failed_images)
- {
- caf_internal_error ("Failed images present (currently %d)", stat,
- errmsg, errmsg_len,
- this_image.supervisor->failed_images);
- if (stat)
- *stat = CAF_STAT_FAILED_IMAGE;
- }
+ caf_internal_error ("Failed images present (currently %d)", stat,
+ errmsg, errmsg_len, failed);
+ if (stat)
+ *stat = CAF_STAT_FAILED_IMAGE;
+ return CAF_STAT_FAILED_IMAGE;
}
- else if (stat)
+
+ if (stat)
*stat = 0;
+ return 0;
}
diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h
index 415ecda2cb8..9f84e420838 100644
--- a/libgfortran/caf/shmem/teams_mgmt.h
+++ b/libgfortran/caf/shmem/teams_mgmt.h
@@ -87,12 +87,34 @@ extern caf_shmem_team_t caf_teams_formed;
void update_teams_images (caf_shmem_team_t);
/* Same as update_teams_images, but with the team's image_count lock already
- taken. Shaped as a counter_barrier_recheck callback. */
+ taken. */
-void update_teams_images_locked (void *);
+void update_teams_images_locked (caf_shmem_team_t);
-void check_health (int *, char *, size_t);
+/* A counter_barrier_recheck: update_teams_images_locked, returning non-zero
+ when a stopped image is a member of the team. */
-#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
+int update_and_check_stopped (void *);
+
+/* Get the number of images of the team that have terminated. */
+
+int team_terminated_images (caf_shmem_team_t);
+
+/* Set STAT for the stopped or failed images among the COUNT images in MAP.
+ Returns the stat value. */
+
+int check_health (const int *map, int count, int *stat, char *errmsg,
+ size_t errmsg_len);
+
+/* Perform the health check on the specified team. */
+
+#define TEAM_HEALTH_CHECK(team, stat, errmsg, errlen) \
+ check_health ((team)->u.image_info->image_map, \
+ (team)->u.image_info->image_map_size, stat, errmsg, errlen)
+
+/* Perform the health check on the current team. */
+
+#define HEALTH_CHECK(stat, errmsg, errlen) \
+ TEAM_HEALTH_CHECK (caf_current_team, stat, errmsg, errlen)
#endif
--
2.55.0
