The attached patch is version 2 of 3 of 3.
(Patch 3 depends on patch 2)
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.
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. A stopping image now
marks the barriers of its teams as aborting: SYNC ALL and SYNC TEAM no
longer wait in them, and a round they already wait in is aborted.
Images waiting in END TEAM, CHANGE TEAM or at program end take part in
the next round instead.
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.
Not addressed: 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, _gfortran_caf_fail_image): Tell leave_teams whether
the image stopped.
(_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_sync): Give up when an
image of the team terminated.
* caf/shmem/counter_barrier.c (counter_barrier_init): Initialize the
new fields.
(next_round, wait_round): New functions.
(counter_barrier_wait): Use wait_round. Take part in the next round
when a round is aborted.
(counter_barrier_wait_abortable, counter_barrier_abort_locked): New
functions.
* caf/shmem/counter_barrier.h (counter_barrier): Make
curr_wait_group a round number. Add aborted_round,
abortable_arrivals and aborting.
(counter_barrier_wait_abortable, counter_barrier_abort_locked):
Declare.
* caf/shmem/sync.c (sync_all): Return whether the images were
synchronized.
(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_teams_images_locked, leave_team): New functions.
(update_teams_images): Use update_teams_images_locked.
(leave_teams): Add stopped argument. Use leave_team.
(check_health): Classify the given images. Return the stat value.
* caf/shmem/teams_mgmt.h (leave_teams, 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 3b3b23627aa280d714ef9a0d117f579fc196dc80 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sat, 19 Sep 2026 12:24:04 -0700
Subject: [PATCH v2 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.
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. A stopping image now
marks the barriers of its teams as aborting: SYNC ALL and SYNC TEAM no
longer wait in them, and a round they already wait in is aborted.
Images waiting in END TEAM, CHANGE TEAM or at program end take part in
the next round instead.
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.
Not addressed: 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, _gfortran_caf_fail_image): Tell leave_teams whether
the image stopped.
(_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_sync): Give up when an
image of the team terminated.
* caf/shmem/counter_barrier.c (counter_barrier_init): Initialize the
new fields.
(next_round, wait_round): New functions.
(counter_barrier_wait): Use wait_round. Take part in the next round
when a round is aborted.
(counter_barrier_wait_abortable, counter_barrier_abort_locked): New
functions.
* caf/shmem/counter_barrier.h (counter_barrier): Make
curr_wait_group a round number. Add aborted_round,
abortable_arrivals and aborting.
(counter_barrier_wait_abortable, counter_barrier_abort_locked):
Declare.
* caf/shmem/sync.c (sync_all): Return whether the images were
synchronized.
(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_teams_images_locked, leave_team): New functions.
(update_teams_images): Use update_teams_images_locked.
(leave_teams): Add stopped argument. Use leave_team.
(check_health): Classify the given images. Return the stat value.
* caf/shmem/teams_mgmt.h (leave_teams, 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 | 35 ++++-
libgfortran/caf/shmem/collective_subroutine.c | 10 +-
libgfortran/caf/shmem/counter_barrier.c | 81 ++++++++---
libgfortran/caf/shmem/counter_barrier.h | 25 +++-
libgfortran/caf/shmem/sync.c | 10 +-
libgfortran/caf/shmem/sync.h | 9 +-
libgfortran/caf/shmem/teams_mgmt.c | 126 +++++++++++++-----
libgfortran/caf/shmem/teams_mgmt.h | 23 +++-
13 files changed, 369 insertions(+), 72 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 89fad8a8f4b..00d851ab539 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);
@@ -585,7 +590,7 @@ mark_stopped (void)
= IMAGE_SUCCESS;
atomic_fetch_add (&this_image.supervisor->finished_images, 1);
}
- leave_teams ();
+ leave_teams (true);
}
/* Tell the supervisor that this image error stopped, so that it can terminate
@@ -650,7 +655,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 ();
+ leave_teams (false);
exit (0);
}
@@ -847,6 +852,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;
@@ -942,6 +950,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,
@@ -964,6 +975,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,
@@ -986,6 +1000,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,
@@ -1008,6 +1025,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,
@@ -1936,7 +1956,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..f97789cab1c 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"
@@ -219,12 +220,17 @@ get_collsub_buf (size_t size)
}
/* This function syncs all images with one another. It will only return once
- all images have called it. */
+ all images have called it. The reduction is laid out over a fixed set of
+ images, so it cannot be completed once an image of the team terminated. */
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_abortable (barrier))
+ 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 1993b1ebeea..8598d79d69d 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -48,35 +48,80 @@ 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,
+ .aborting = false,
+ .count = val};
initialize_shared_condition (&b->cond, val);
initialize_shared_mutex (&b->mutex);
}
+/* 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);
+}
+
+/* Take part in the current round of the barrier, with its lock held. Returns
+ false, when the round was aborted. */
+
+static bool
+wait_round (counter_barrier *b, bool abortable)
+{
+ const uint64_t round = b->curr_wait_group;
+
+ if (abortable)
+ ++b->abortable_arrivals;
+ --b->wait_count;
+ while (b->wait_count > 0 && b->curr_wait_group == round)
+ caf_shmem_cond_wait (&b->cond, &b->mutex);
+
+ /* The last image to arrive, or to be woken after the count dropped, ends
+ the round. */
+ if (b->curr_wait_group == round)
+ next_round (b, false);
+
+ return b->aborted_round != round;
+}
+
void
counter_barrier_wait (counter_barrier *b)
{
- int wait_group_beginning;
-
lock_counter_barrier (b);
- wait_group_beginning = b->curr_wait_group;
-
- if ((--b->wait_count) <= 0)
- caf_shmem_cond_broadcast (&b->cond);
- else
- {
- while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
- caf_shmem_cond_wait (&b->cond, &b->mutex);
- }
+ while (!wait_round (b, false))
+ ;
+ unlock_counter_barrier (b);
+}
- if (b->wait_count <= 0)
- {
- b->curr_wait_group = !wait_group_beginning;
- b->wait_count = b->count;
- }
+bool
+counter_barrier_wait_abortable (counter_barrier *b)
+{
+ bool completed;
+ lock_counter_barrier (b);
+ completed = !b->aborting && wait_round (b, true);
unlock_counter_barrier (b);
+ return completed;
+}
+
+void
+counter_barrier_abort_locked (counter_barrier *b)
+{
+ b->aborting = true;
+ if (b->abortable_arrivals)
+ next_round (b, true);
}
static inline void
diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h
index 7d7c724ae06..7b6d3d88e71 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,14 @@ 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 abortable arrivals in the current round. */
+ volatile int abortable_arrivals;
+ /* Set once abortable arrivals are no longer to be synchronized. */
+ volatile bool aborting;
volatile int count;
} counter_barrier;
@@ -73,8 +83,19 @@ 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. */
+/* Wait for the count in the barrier drop to or below 0. When the round is
+ aborted, take part in the next one. */
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. */
+
+bool counter_barrier_wait_abortable (counter_barrier *);
+
+/* Abort the current round when it has an abortable arrival, and every later
+ abortable arrival. The barrier's lock has to be held. */
+
+void counter_barrier_abort_locked (counter_barrier *);
+
#endif
diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c
index f1d5bedbc8e..511a8525424 100644
--- a/libgfortran/caf/shmem/sync.c
+++ b/libgfortran/caf/shmem/sync.c
@@ -128,10 +128,10 @@ sync_table (sync_t *si, int *images, int size)
unlock_table (si);
}
-void
+bool
sync_all (void)
{
- counter_barrier_wait (&caf_current_team->u.image_info->image_count);
+ return sync_team_unless_stopped (caf_current_team);
}
void
@@ -140,6 +140,12 @@ sync_team (caf_shmem_team_t team)
counter_barrier_wait (&team->u.image_info->image_count);
}
+bool
+sync_team_unless_stopped (caf_shmem_team_t team)
+{
+ return counter_barrier_wait_abortable (&team->u.image_info->image_count);
+}
+
void
lock_event (sync_t *si)
{
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 02f37f28590..d90ece310ba 100644
--- a/libgfortran/caf/shmem/teams_mgmt.c
+++ b/libgfortran/caf/shmem/teams_mgmt.c
@@ -28,65 +28,119 @@ 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 (caf_shmem_team_t team)
+/* 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)
+{
+ int i, n = 0;
+
+ for (i = 0; i < count; ++i)
+ if (this_image.supervisor->images[map[i]].status == status)
+ ++n;
+
+ return n;
+}
+
+/* Get the number of images of TEAM that have terminated. */
+
+static 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;
+}
+
+static void
+update_teams_images_locked (caf_shmem_team_t team)
{
- caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex);
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
- team->u.image_info->num_term_images);
}
+}
+
+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);
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)
+{
+ counter_barrier *b = &team->u.image_info->image_count;
+ counter_barrier *cb = &team->u.image_info->collsub.barrier;
+
+ caf_shmem_mutex_lock (&b->mutex);
+ update_teams_images_locked (team);
+ if (stopped)
+ counter_barrier_abort_locked (b);
+ caf_shmem_mutex_unlock (&b->mutex);
+
+ caf_shmem_mutex_lock (&cb->mutex);
+ counter_barrier_abort_locked (cb);
+ caf_shmem_mutex_unlock (&cb->mutex);
+}
+
void
-leave_teams (void)
+leave_teams (bool stopped)
{
for (caf_shmem_team_t t = caf_current_team; t; t = t->parent)
- update_teams_images (t);
+ leave_team (t, stopped);
for (caf_shmem_team_t t = caf_teams_formed; t; t = t->parent)
- update_teams_images (t);
+ leave_team (t, stopped);
}
-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)
{
- 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 ("Stopped images present (currently %d)", stat,
+ errmsg, errmsg_len, stopped);
+ if (stat)
+ *stat = CAF_STAT_STOPPED_IMAGE;
+ return CAF_STAT_STOPPED_IMAGE;
}
- else if (stat)
+
+ if (failed)
+ {
+ 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;
+ }
+
+ if (stat)
*stat = 0;
+ return 0;
}
diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h
index efeeefc6e24..143e5b54cd8 100644
--- a/libgfortran/caf/shmem/teams_mgmt.h
+++ b/libgfortran/caf/shmem/teams_mgmt.h
@@ -87,12 +87,27 @@ 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. */
+ member of. When STOPPED, image control statements and collective
+ subroutines no longer synchronize with the other images of these teams.
+ Otherwise only collective subroutines do not. */
-void leave_teams (void);
+void leave_teams (bool stopped);
-void check_health (int *, char *, size_t);
+/* Set STAT for the stopped or failed images among the COUNT images in MAP.
+ Returns the stat value. */
-#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
+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
