On 9/30/26 8:30 AM, Mikael Morin wrote:
Le 30/09/2026 à 00:17, Jerry D a écrit :
On 9/29/26 1:14 AM, Mikael Morin wrote:
Le 28/09/2026 à 22:30, Jerry D a écrit :
I have been out on travel this weekend. I am curious why the email is marked
SPAM? I will look at your comments tomorro.
Yes, sorry about it, I forgot to remove the SPAM marker. There is obviously a
spam filter before I receive the message; it selects its messages more or
less randomly, and it marks them with a tag in the subject rather than with a
dedicated attribute. Yes, it's more a nuisance than an help, but it's out of
my control.
Attached is v2 of the patch. I had claude run fuzz tests on this which
generated about 900 variations. Doing this identified another small adjustment
needed to avoid some timing issues under heavy loads in the counter_barrier.c
code.
Regression tested on x86_64.
Ok for mainline?
Regards,
Jerry
---
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 the 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,
round_terminated and round_terminated_round.
(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.
---
Hello,
there is just one thing that is not completely clear to me.
diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/
counter_barrier.c
index 8598d79d69d..43e80289d23 100644
--- a/libgfortran/caf/shmem/counter_barrier.c
+++ b/libgfortran/caf/shmem/counter_barrier.c
@@ -66,6 +69,10 @@ 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 the
+ round; an image removed later did not take part in it. */
+ b->round_terminated = b->terminated;
+ b->round_terminated_round = b->curr_wait_group;
if (abort)
b->aborted_round = b->curr_wait_group;
++b->curr_wait_group;
@@ -78,9 +85,10 @@ 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;
+ const int at_arrival = b->terminated;
if (abortable)
++b->abortable_arrivals;
@@ -93,6 +101,12 @@ wait_round (counter_barrier *b, bool abortable)
if (b->curr_wait_group == round)
next_round (b, false);
+ if (terminated)
+ /* A later round may have taken its own snapshot in the meantime; the
+ images removed before this one arrived are known to be involved. */
+ *terminated = b->round_terminated_round == round ? b->round_terminated
+ : at_arrival;
+
It seems that returning at_arrival, which is the value saved before waiting,
would return an obsolete value. In which case is b->round_terminated_round
different from round? Isn't next_round run just once before each image executes
this?
return b->aborted_round != round;
}
hmm, you are right that next_round runs once per round. The tag could only
differ when image A, woken from round N, had not yet reacquired the
mutex while the others entered round N+1 of an abortable SYNC ALL and a
STOP aborted it: next_round (b, true) then overwrote the snapshot. No
other round can end without A, since a normal end needs A's arrival
and the aborting flag is sticky.
at_arrival was a lower bound for that case, and it could miss an image
that failed during round N after A arrived (a failed image does not
abort the barrier). Since the waiters of an aborted round return false
and the callers then do a full health check without looking at
TERMINATED, the aborted round does not need a snapshot at all. I will
take it only for a completed round and drop at_arrival and
round_terminated_round, so every waiter of a completed round reads that
round's value.
Here is a version 3 of the patch
Hope this one takes care of it.
Regression tested more than once on x86_64.
OK for mainline?
Regards,
Jerry
---
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.
---
From 9e52652b8b90918b04dcdf71562604826b1ebf5b Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Thu, 24 Sep 2026 12:57:23 -0700
Subject: [PATCH v3] 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.
---
.../gfortran.dg/coarray/signal_sync_1.f90 | 22 ++++++
.../gfortran.dg/coarray/signal_team_1.f90 | 26 +++++++
.../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(-)
create mode 100644 gcc/testsuite/gfortran.dg/coarray/signal_sync_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/signal_team_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_failed_stat_1.f90
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 00000000000..416cee6d8e6
--- /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 00000000000..958801a7fda
--- /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 00000000000..d6f2d785999
--- /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 aacb1fd6f86..fe1e5e29384 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 911c54acbee..fbbe93e80f2 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 8598d79d69d..1a30e45dda7 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 7b6d3d88e71..2eb886545b1 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 d63b58e3647..246f98aab63 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 a956092e263..ea122de12b2 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 511a8525424..9deb31f0871 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 0aa596c9eff..d7b96992840 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 d90ece310ba..9e04ee9da10 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 3b0c3b6aa22..b87fc6f87d1 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
--
2.55.0
