See attached patch. This implements the teams registry solution for tracking
failed images.
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=.
Assisted-by: Claude Opus 5.5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_form_team): Register the team.
* 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/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.
---
From 8d186b5798949881c26a5f3e324901450132915f Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Thu, 24 Sep 2026 12:57:23 -0700
Subject: [PATCH] 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=.
Assisted-by: Claude Opus 5.5
PR libfortran/127347
libgfortran/ChangeLog:
* caf/shmem.c (_gfortran_caf_form_team): Register the team.
* 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/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/signal_sync_1.f90 | 22 ++++++
.../gfortran.dg/coarray/signal_team_1.f90 | 26 +++++++
libgfortran/caf/shmem.c | 1 +
libgfortran/caf/shmem/supervisor.c | 5 ++
libgfortran/caf/shmem/supervisor.h | 4 +
libgfortran/caf/shmem/teams_mgmt.c | 78 ++++++++++++++-----
libgfortran/caf/shmem/teams_mgmt.h | 13 ++++
7 files changed, 128 insertions(+), 21 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
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/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c
index aacb1fd6f86..be5e640c7f5 100644
--- a/libgfortran/caf/shmem.c
+++ b/libgfortran/caf/shmem.c
@@ -1802,6 +1802,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)
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/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
