* Interoperability Options:: Options for interoperability with other
languages.
* Environment Variables:: Environment variables that affect @command{gfortran}.
+* Shared Memory Coarrays:: Multi process shared memory coarray support.
@end menu
@node Option Summary
@xref{Runtime}, for environment variables that affect the
run-time behavior of programs compiled with GNU Fortran.
@c man end
+
+@node Shared Memory Coarrays
+@section Shared Memory Coarrays
+
+@c man begin SHARED MEMORY COARRAYS
+
+@command{gfortran} supplies a runtime library for running coarray enabled
+programs using a shared memory multi process approach. The library is supplied
+as a static link library with the @command{libgfortran} library and is fully
+compatible with the ABI enabled when @command{gfortran} is called with
+@code{-fcoarray=lib}. The shared memory coarray library then just needs to be
+linked to the executable produced by @command{gfortran} using
+@code{-lcaf_shmem}.
+
+The library @code{caf_shmem} can only be used on architectures that allow
+multiple processes to use the same memory at the same virtual memory address in
+each process' memory space. This is the case on most Unix and Windows based
+systems.
+
+The resulting executable can be started without any driver and does not provide
+any additional command line options. Limited control is possible by
+environment variables:
+
+@env{GFORTRAN_NUM_IMAGES}: The number of images to spawn when running the
+executable. Note, there will always be one additional supervisor process, which
+does not participate in the computation, but is only responsible for starting
+the images and catching any (ab-)normal termination. When the environment
+variable is not set, then the number of hardware threads reported by the OS will
+be taken. Over-provisioning is possible. The number of images is limited only
+by the OS and the size of an integer variable on the architecture the program is
+to be run on.
+
+@env{GFORTRAN_SHARED_MEMORY_SIZE}: The size of the shared memory segment made
+available to all images is fixed and needs to be set at program start. It can
+not grow or shrink. The size can be given in bytes (no suffix), kilobytes
+(@code{k} or @code{K} suffix), megabytes (@code{m} or @code{M}) or gigabytes
+(@code{g} or @code{G}). If the variable is not set, or not parseable, then on
+32-bit architectures 2^28 bytes and on 64-bit 2^34 bytes are choosen. Note,
+although the size is set, most modern systems do not allocate the memory at
+program start. This allows to choose a shared memory size larger than available
+memory.
+
+Warning: Choosing a large shared memory size may produce large coredumps!
+
+The shared memory coarray library internally uses some additional environment
+variables, which will be overwritten without notice or may result in failure to
+start. These are: @code{GFORTRAN_IMAGE_NUM}, @code{GFORTRAN_SHMEM_PID} and
+@code{GFORTRAN_SHMEM_BASE}. It is strongly discouraged to use these variables.
+Special care needs to be taken, when one coarray program starts another coarray
+program as a child process. In this case it is the spawning process'
+responsibility to remove above variables from the environment.
+
+@c man end
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 <stdarg.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+static void
+internal_caf_runtime_error (const char *format, va_list args)
+{
+ fprintf (stderr, "Fortran runtime error: ");
+ vfprintf (stderr, format, args);
+ fprintf (stderr, "\n");
+
+ exit (EXIT_FAILURE);
+}
+
+void
+caf_runtime_error (const char *format, ...)
+{
+ va_list ap;
+ va_start (ap, format);
+ internal_caf_runtime_error (format, ap);
+}
+
+void
+caf_internal_error (const char *format, int *stat, char *errmsg,
+ size_t errmsg_len, ...)
+{
+ va_list args;
+ va_start (args, errmsg_len);
+ if (stat)
+ {
+ *stat = 1;
+ if (errmsg_len > 0)
+ {
+ int len = vsnprintf (errmsg, errmsg_len, format, args);
+ if (len >= 0 && errmsg_len > (size_t) len)
+ memset (&errmsg[len], ' ', errmsg_len - len);
+ }
+ va_end (args);
+ return;
+ }
+ else
+ internal_caf_runtime_error (format, args);
+ va_end (args);
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef CAF_ERROR_H
+#define CAF_ERROR_H
+
+#include <stddef.h>
+
+/* Emit a printf style error message and exit with EXIT_FAILURE. */
+
+void caf_runtime_error (const char *format, ...);
+
+/* If `stat` is given, it will be set to 1 and procedure returns to the caller.
+ If additionally `errmsg` is non-NULL, then printf-style `format` will by
+ printed to `errmsg`. If the resulting message is longer then `errmsg_len`,
+ it will be truncated, else filled with spaces.
+ If `stat` is not given, then the printf-formated message will be emited to
+ stderr and the program terminates with EXIT_FAILURE. */
+
+void caf_internal_error (const char *format, int *stat, char *errmsg,
+ size_t errmsg_len, ...);
+
+#endif
#ifndef LIBCAF_H
#define LIBCAF_H
-#include <stdbool.h>
-#include <stddef.h> /* For size_t. */
-
#include "libgfortran.h"
/* Definitions of the Fortran 2008 standard; need to kept in sync with
--- /dev/null
+/* Shared memory-multiple (process)-image implementation of GNU Fortran
+ Coarray Library
+ Copyright (C) 2011-2025 Free Software Foundation, Inc.
+ Based on single.c contributed by Tobias Burnus <burnus@net-b.de>
+
+This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
+
+Libcaf is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Libcaf is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "libcaf.h"
+#include "caf_error.h"
+
+#include "shmem/counter_barrier.h"
+#include "shmem/supervisor.h"
+#include "shmem/teams_mgmt.h"
+#include "shmem/thread_support.h"
+
+#include <stdlib.h> /* For exit and malloc. */
+#include <string.h> /* For memcpy and memset. */
+#include <stdint.h>
+#include <assert.h>
+#include <errno.h>
+#include <unistd.h>
+
+/* Define GFC_CAF_CHECK to enable run-time checking. */
+/* #define GFC_CAF_CHECK 1 */
+
+#define TOKEN(X) ((caf_shmem_token_t) (X))
+#define MEMTOK(X) ((caf_shmem_token_t) (X))->memptr
+
+/* Global variables. */
+static caf_static_t *caf_static_list = NULL;
+memid next_memid = 0;
+
+typedef void (*getter_t) (void *, const int *, void **, int32_t *, void *,
+ caf_token_t, const size_t, size_t *, const size_t *);
+typedef void (*is_present_t) (void *, const int *, int32_t *, void *,
+ caf_shmem_token_t, const size_t);
+typedef void (*receiver_t) (void *, const int *, void *, const void *,
+ caf_token_t, const size_t, const size_t *,
+ const size_t *);
+struct accessor_hash_t
+{
+ int hash;
+ int pad;
+ union
+ {
+ getter_t getter;
+ is_present_t is_present;
+ receiver_t receiver;
+ } u;
+};
+
+static struct accessor_hash_t *accessor_hash_table = NULL;
+static int aht_cap = 0;
+static int aht_size = 0;
+static enum {
+ AHT_UNINITIALIZED,
+ AHT_OPEN,
+ AHT_PREPARED
+} accessor_hash_table_state
+ = AHT_UNINITIALIZED;
+
+void
+_gfortran_caf_init (int *argc, char ***argv)
+{
+ int exit_code = 0;
+
+ ensure_shmem_initialization ();
+
+ if (shared_memory_get_env ())
+ {
+ /* This is the initialization of a worker. */
+ _gfortran_caf_sync_all (NULL, NULL, 0);
+ return;
+ }
+
+ if (supervisor_main_loop (argc, argv, &exit_code))
+ return;
+ shared_memory_cleanup (&local->sm);
+
+ /* Free pseudo tokens and memory to allow main process to survive caf_init.
+ */
+ while (caf_static_list != NULL)
+ {
+ caf_static_t *tmp = caf_static_list->prev;
+ free (((caf_shmem_token_t) caf_static_list->token)->base);
+ free (caf_static_list->token);
+ free (caf_static_list);
+ caf_static_list = tmp;
+ }
+ free (local);
+ exit (exit_code);
+}
+
+static void
+free_team_list (caf_shmem_team_t l)
+{
+ while (l != NULL)
+ {
+ caf_shmem_team_t p = l->parent;
+ struct coarray_allocated *ca = l->allocated;
+ while (ca)
+ {
+ struct coarray_allocated *nca = ca->next;
+ free (ca);
+ ca = nca;
+ }
+ free (l);
+ l = p;
+ }
+}
+
+void
+_gfortran_caf_finalize (void)
+{
+ free (accessor_hash_table);
+
+ while (caf_static_list != NULL)
+ {
+ caf_static_t *tmp = caf_static_list->prev;
+ alloc_free_memory_with_id (
+ &local->ai,
+ (memid) ((caf_shmem_token_t) caf_static_list->token)->token_id);
+ free (caf_static_list->token);
+ free (caf_static_list);
+ caf_static_list = tmp;
+ }
+
+ free_team_list (caf_current_team);
+ caf_initial_team = caf_current_team = NULL;
+ free_team_list (caf_teams_formed);
+ caf_teams_formed = NULL;
+
+ free (local);
+}
+
+int
+_gfortran_caf_this_image (caf_team_t team)
+{
+ return (team ? ((caf_shmem_team_t) team)->index : caf_current_team->index)
+ + 1;
+}
+
+int
+_gfortran_caf_num_images (caf_team_t team, int32_t *team_number)
+{
+#define CHECK_TEAMS \
+ while (cur) \
+ { \
+ if (cur->u.image_info->team_id == *team_number) \
+ return counter_barrier_get_count (&cur->u.image_info->image_count); \
+ cur = cur->parent; \
+ }
+
+ if (team)
+ return counter_barrier_get_count (
+ &((caf_shmem_team_t) team)->u.image_info->image_count);
+
+ if (team_number)
+ {
+ caf_shmem_team_t cur = caf_current_team;
+
+ CHECK_TEAMS
+
+ cur = caf_teams_formed;
+ CHECK_TEAMS
+ }
+
+ return counter_barrier_get_count (
+ &caf_current_team->u.image_info->image_count);
+}
+
+
+void
+_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
+ gfc_descriptor_t *data, int *stat, char *errmsg,
+ size_t errmsg_len)
+{
+ static bool inited = false;
+ const char alloc_fail_msg[] = "Failed to allocate coarray";
+ void *mem;
+ caf_shmem_token_t shmem_token;
+
+ /* When the master has not been initialized, we could either be in the
+ control process or in the static initializer phase. */
+ if (unlikely (!inited))
+ {
+ if (local == NULL)
+ {
+ if (shared_memory_get_env ())
+ {
+ /* This is the static initializer phase. Register the static
+ coarrays or we are in trouble later. */
+ ensure_shmem_initialization ();
+ inited = true;
+ }
+ else if (type == CAF_REGTYPE_COARRAY_STATIC)
+ {
+ /* This is the control process, but it also runs the static
+ initializers (the caf_init.N() procedures). In these it may
+ want to assign to members (effectively NULL them) of derived
+ types. Therefore the need to return valid memory blocks.
+ These are never used and do not participate in any coarray
+ routine. They unfortunately just waste some memory. */
+ mem = malloc (size);
+ GFC_DESCRIPTOR_DATA (data) = mem;
+ caf_static_t *tmp = malloc (sizeof (caf_static_t));
+ *token = malloc (sizeof (struct caf_shmem_token));
+ **(caf_shmem_token_t *) token
+ = (struct caf_shmem_token) {mem, NULL, mem, size, ~0U, true};
+ *tmp = (caf_static_t) {*token, caf_static_list};
+ caf_static_list = tmp;
+ return;
+ }
+ else
+ return;
+ }
+ }
+
+ /* Catch all special cases. */
+ switch (type)
+ {
+ /* When mapping, read from the old token. */
+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:
+ /* The mapping could involve an offset that is mangled into the array's
+ data ptr. */
+ mem
+ = ((caf_shmem_token_t) *token)->base
+ + (GFC_DESCRIPTOR_DATA (data) - ((caf_shmem_token_t) *token)->memptr);
+ size = ((caf_shmem_token_t) *token)->image_size;
+ break;
+ case CAF_REGTYPE_EVENT_ALLOC:
+ case CAF_REGTYPE_EVENT_STATIC:
+ size *= sizeof (void *);
+ break;
+ default:
+ break;
+ }
+
+ if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+ *token = malloc (sizeof (struct caf_shmem_token));
+
+ size = alignto (size, sizeof (ptrdiff_t));
+ switch (type)
+ {
+ case CAF_REGTYPE_LOCK_STATIC:
+ case CAF_REGTYPE_LOCK_ALLOC:
+ case CAF_REGTYPE_CRITICAL:
+ {
+ lock_t *addr;
+ bool created;
+
+ allocator_lock (&local->ai.alloc);
+ /* Allocate enough space for the metadata infront of the lock
+ array. */
+ addr
+ = alloc_get_memory_by_id_created (&local->ai, size * sizeof (lock_t),
+ next_memid, &created);
+
+ if (created)
+ {
+ /* Initialize the mutex only, when the memory was allocated for the
+ first time. */
+ for (size_t c = 0; c < size; ++c)
+ initialize_shared_errorcheck_mutex (&addr[c]);
+ }
+ size *= sizeof (lock_t);
+
+ allocator_unlock (&local->ai.alloc);
+ mem = addr;
+ break;
+ }
+ case CAF_REGTYPE_EVENT_STATIC:
+ case CAF_REGTYPE_EVENT_ALLOC:
+ {
+ bool created;
+
+ allocator_lock (&local->ai.alloc);
+ mem = alloc_get_memory_by_id_created (
+ &local->ai, size * caf_current_team->u.image_info->image_count.count,
+ next_memid, &created);
+ if (created)
+ memset (mem, 0,
+ size * caf_current_team->u.image_info->image_count.count);
+ allocator_unlock (&local->ai.alloc);
+ }
+ break;
+ case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY:
+ mem = NULL;
+ break;
+ case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY:
+ allocator_lock (&local->ai.alloc);
+ mem = SHMPTR_AS (void *, allocator_shared_malloc (&local->ai.alloc, size),
+ &local->sm);
+ allocator_unlock (&local->ai.alloc);
+ break;
+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:
+ /* Computing the mem ptr is done above before the new token is allocated.
+ */
+ break;
+ default:
+ mem = alloc_get_memory_by_id (
+ &local->ai, size * caf_current_team->u.image_info->image_count.count,
+ next_memid);
+ break;
+ }
+
+ if (unlikely (
+ *token == NULL
+ || (mem == NULL && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
+ {
+ /* Freeing the memory conditionally seems pointless, but
+ caf_internal_error () may return, when a stat is given and then the
+ memory may be lost. */
+ if (mem)
+ alloc_free_memory_with_id (&local->ai, next_memid);
+ free (*token);
+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+ return;
+ }
+
+ shmem_token = TOKEN (*token);
+ switch (type)
+ {
+ case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY:
+ *shmem_token
+ = (struct caf_shmem_token) {NULL, NULL, NULL, size, ~0U, false};
+ break;
+ case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY:
+ shmem_token->memptr = mem;
+ shmem_token->base = mem;
+ shmem_token->image_size = size;
+ shmem_token->owning_memory = true;
+ break;
+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:
+ *shmem_token
+ = (struct caf_shmem_token) {mem + size * this_image.image_num,
+ GFC_DESCRIPTOR_RANK (data) > 0 ? data
+ : NULL,
+ mem,
+ size,
+ next_memid++,
+ false};
+ break;
+ case CAF_REGTYPE_LOCK_STATIC:
+ case CAF_REGTYPE_LOCK_ALLOC:
+ case CAF_REGTYPE_CRITICAL:
+ *shmem_token = (struct caf_shmem_token) {
+ mem, GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL,
+ mem, size,
+ next_memid++, false};
+ break;
+ default:
+ *shmem_token
+ = (struct caf_shmem_token) {mem + size * this_image.image_num,
+ GFC_DESCRIPTOR_RANK (data) > 0 ? data
+ : NULL,
+ mem,
+ size,
+ next_memid++,
+ true};
+ break;
+ }
+
+ if (stat)
+ *stat = 0;
+
+ if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC)
+ {
+ caf_static_t *tmp = malloc (sizeof (caf_static_t));
+ *tmp = (caf_static_t) {*token, caf_static_list};
+ caf_static_list = tmp;
+ }
+ else
+ {
+ struct coarray_allocated *ca = caf_current_team->allocated;
+ for (; ca && ca->token != shmem_token; ca = ca->next)
+ ;
+ if (!ca)
+ {
+ ca = (struct coarray_allocated *) malloc (
+ sizeof (struct coarray_allocated));
+ *ca = (struct coarray_allocated) {caf_current_team->allocated,
+ shmem_token};
+ caf_current_team->allocated = ca;
+ }
+ }
+ GFC_DESCRIPTOR_DATA (data) = shmem_token->memptr;
+}
+
+void
+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ caf_shmem_token_t shmem_token = TOKEN (*token);
+
+ if (shmem_token->owning_memory && shmem_token->memptr)
+ {
+ if (shmem_token->token_id != ~0U)
+ alloc_free_memory_with_id (&local->ai, (memid) shmem_token->token_id);
+ else
+ {
+ allocator_lock (&local->ai.alloc);
+ allocator_shared_free (&local->ai.alloc,
+ AS_SHMPTR (shmem_token->base, local->sm),
+ shmem_token->image_size);
+ allocator_unlock (&local->ai.alloc);
+ }
+
+ if (shmem_token->desc)
+ GFC_DESCRIPTOR_DATA (shmem_token->desc) = NULL;
+ }
+
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ struct coarray_allocated *ca = caf_current_team->allocated;
+ if (ca && caf_current_team->allocated->token == shmem_token)
+ caf_current_team->allocated = ca->next;
+ else
+ {
+ struct coarray_allocated *pca = NULL;
+ for (; ca && ca->token != shmem_token; pca = ca, ca = ca->next)
+ ;
+ if (!ca)
+ caf_runtime_error (
+ "Coarray token to be freeed is not in current team %d", type);
+ /* Unhook found coarray_allocated node from list... */
+ pca->next = ca->next;
+ }
+ /* ... and free. */
+ free (ca);
+ free (TOKEN (*token));
+ *token = NULL;
+ }
+ else
+ {
+ shmem_token->memptr = NULL;
+ shmem_token->owning_memory = false;
+ }
+
+ if (stat)
+ *stat = 0;
+}
+
+void
+_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 ();
+}
+
+
+void
+_gfortran_caf_sync_memory (int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ __asm__ __volatile__ ("":::"memory");
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,
+ size_t errmsg_len)
+{
+ int *mapped_images = images;
+
+ CHECK_TEAM_INTEGRITY (caf_current_team);
+ if (count > 0)
+ {
+ int *map = caf_current_team->u.image_info->image_map;
+ int max_id = caf_current_team->u.image_info->image_map_size;
+
+ mapped_images = __builtin_alloca (sizeof (int) * count);
+ if (!mapped_images)
+ {
+ caf_internal_error ("SYNC IMAGES: Can not reserve buffer for mapping "
+ "images to internal ids. Increase stack size!",
+ stat, errmsg, errmsg_len);
+ return;
+ }
+ for (int c = 0; c < count; ++c)
+ {
+ if (images[c] > 0 && images[c] <= max_id)
+ {
+ mapped_images[c] = map[images[c] - 1];
+ switch (this_image.supervisor->images[mapped_images[c]].status)
+ {
+ case IMAGE_SUCCESS:
+ caf_internal_error ("SYNC IMAGES: Image %d is stopped", stat,
+ errmsg, errmsg_len, images[c]);
+ /* We can come here only, when stat is non-NULL. */
+ *stat = CAF_STAT_STOPPED_IMAGE;
+ return;
+ case IMAGE_FAILED:
+ caf_internal_error ("SYNC IMAGES: Image %d has failed", stat,
+ errmsg, errmsg_len, images[c]);
+ /* We can come here only, when stat is non-NULL. */
+ *stat = CAF_STAT_FAILED_IMAGE;
+ return;
+ default:
+ break;
+ }
+ for (int i = 0; i < c; ++i)
+ if (mapped_images[c] == mapped_images[i])
+ {
+ caf_internal_error ("SYNC IMAGES: Duplicate image %d in "
+ "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
+ OpenCoarray uses. */
+ *stat = 3;
+ return;
+ }
+ }
+ else
+ {
+ caf_internal_error ("Invalid image number %d in SYNC IMAGES",
+ stat, errmsg, errmsg_len, images[c]);
+ return;
+ }
+ }
+ }
+ else
+ HEALTH_CHECK (stat, errmsg, errmsg_len);
+
+ __asm__ __volatile__ ("" ::: "memory");
+ sync_table (&local->si, mapped_images, count);
+ HEALTH_CHECK (stat, errmsg, errmsg_len);
+}
+
+extern void _gfortran_report_exception (void);
+
+void
+_gfortran_caf_stop_numeric (int stop_code, bool quiet)
+{
+ if (!quiet)
+ {
+ _gfortran_report_exception ();
+ fprintf (stderr, "STOP %d\n", stop_code);
+ }
+ exit (stop_code);
+}
+
+void
+_gfortran_caf_stop_str (const char *string, size_t len, bool quiet)
+{
+ if (!quiet)
+ {
+ _gfortran_report_exception ();
+ fputs ("STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
+ exit (0);
+}
+
+
+void
+_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
+{
+ if (!quiet)
+ {
+ _gfortran_report_exception ();
+ fputs ("ERROR STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
+ exit (1);
+}
+
+/* Report that the program terminated because of a fail image issued. */
+
+void
+_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);
+ exit (0);
+}
+
+/* Get the status of image IMAGE. */
+
+int
+_gfortran_caf_image_status (int image, caf_team_t *team)
+{
+ caf_shmem_team_t t = caf_current_team;
+ int image_index;
+
+ if (team)
+ t = *(caf_shmem_team_t *) team;
+
+ if (image > t->u.image_info->image_count.count)
+ return CAF_STAT_STOPPED_IMAGE;
+
+ image_index = t->u.image_info->image_map[image - 1];
+
+ switch (this_image.supervisor->images[image_index].status)
+ {
+ case IMAGE_FAILED:
+ return CAF_STAT_FAILED_IMAGE;
+ case IMAGE_SUCCESS:
+ return CAF_STAT_STOPPED_IMAGE;
+
+ /* When image status is not known, return 0. */
+ case IMAGE_OK:
+ case IMAGE_UNKNOWN:
+ default:
+ return 0;
+ }
+}
+
+static void
+stopped_or_failed_images (gfc_descriptor_t *array, caf_team_t *team, int *kind,
+ image_status img_stat, const char *function_name)
+{
+ int local_kind = kind != NULL ? *kind : 4;
+ size_t sti = 0;
+ caf_shmem_team_t t = caf_current_team;
+
+ if (team)
+ t = *(caf_shmem_team_t *) team;
+
+ int sz = t->u.image_info->image_map_size;
+ for (int i = 0; i < sz; ++i)
+ if (this_image.supervisor->images[t->u.image_info->image_map[i]].status
+ == img_stat)
+ ++sti;
+
+ if (sti)
+ {
+ array->base_addr = malloc (local_kind * sti);
+ array->dtype.type = BT_INTEGER;
+ array->dtype.elem_len = local_kind;
+ array->dim[0].lower_bound = 1;
+ array->dim[0]._ubound = sti;
+ array->dim[0]._stride = 1;
+ array->span = local_kind;
+ array->offset = 0;
+ sti = 0;
+ for (int i = 0; i < sz; ++i)
+ if (this_image.supervisor->images[t->u.image_info->image_map[i]].status
+ == img_stat)
+ switch (local_kind)
+ {
+ case 1:
+ ((int8_t *) array->base_addr)[sti++] = i + 1;
+ break;
+ case 2:
+ ((int16_t *) array->base_addr)[sti++] = i + 1;
+ break;
+ case 4:
+ ((int32_t *) array->base_addr)[sti++] = i + 1;
+ break;
+ case 8:
+ ((int64_t *) array->base_addr)[sti++] = i + 1;
+ break;
+ default:
+ caf_runtime_error ("Unsupported kind %d in %s.", local_kind,
+ function_name);
+ }
+ }
+ else
+ {
+ array->base_addr = NULL;
+ array->dtype.type = BT_INTEGER;
+ array->dtype.elem_len = local_kind;
+ /* Setting lower_bound higher then upper_bound is what the compiler does
+ to indicate an empty array. */
+ array->dim[0].lower_bound = 0;
+ array->dim[0]._ubound = -1;
+ array->dim[0]._stride = 1;
+ array->offset = 0;
+ }
+}
+
+void
+_gfortran_caf_failed_images (gfc_descriptor_t *array, caf_team_t *team,
+ int *kind)
+{
+ stopped_or_failed_images (array, team, kind, IMAGE_FAILED, "FAILED_IMAGES()");
+}
+
+void
+_gfortran_caf_stopped_images (gfc_descriptor_t *array, caf_team_t *team,
+ int *kind)
+{
+ stopped_or_failed_images (array, team, kind, IMAGE_SUCCESS,
+ "STOPPED_IMAGES()");
+}
+
+void
+_gfortran_caf_error_stop (int error, bool quiet)
+{
+ if (!quiet)
+ {
+ _gfortran_report_exception ();
+ fprintf (stderr, "ERROR STOP %d\n", error);
+ }
+ exit (error);
+}
+
+static bool
+check_get_team (caf_team_t *team, int *team_number, int *stat,
+ caf_shmem_team_t *cur_team)
+{
+ if (team || team_number)
+ {
+ *cur_team = caf_current_team;
+
+ if (team)
+ {
+ caf_shmem_team_t cand_team = (caf_shmem_team_t) (*team);
+ while (*cur_team && *cur_team != cand_team)
+ *cur_team = (*cur_team)->parent;
+ }
+ else
+ while (*cur_team && (*cur_team)->u.image_info->team_id != *team_number)
+ *cur_team = (*cur_team)->parent;
+
+ if (!*cur_team)
+ {
+ if (stat)
+ {
+ *stat = 1;
+ return false;
+ }
+ else
+ caf_runtime_error ("requested team not found");
+ }
+ }
+ else
+ *cur_team = caf_current_team;
+
+ CHECK_TEAM_INTEGRITY ((*cur_team));
+ return true;
+}
+
+static bool
+check_map_team (int *remote_index, int *this_index, const int image_index,
+ caf_team_t *team, int *team_number, int *stat)
+{
+ caf_shmem_team_t selected_team;
+ const bool check = check_get_team (team, team_number, stat, &selected_team);
+
+ if (!selected_team)
+ return false;
+#ifndef NDEBUG
+ if (image_index < 1
+ || image_index > selected_team->u.image_info->image_map_size)
+ {
+ if (stat)
+ *stat = 1;
+ return false;
+ }
+#endif
+
+ *remote_index = selected_team->u.image_info->image_map[image_index - 1];
+
+ *this_index = this_image.image_num;
+
+ return check;
+}
+
+void
+_gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int mapped_index, this_image_index;
+ if (stat)
+ *stat = 0;
+
+ if (!check_map_team (&mapped_index, &this_image_index, source_image, NULL,
+ NULL, stat))
+ return;
+
+ collsub_broadcast_array (desc, mapped_index);
+}
+
+#define GEN_OP(name, op, type) \
+ static type name##_##type (type *lhs, type *rhs) { return op (*lhs, *rhs); }
+
+#define GEN_OP_SERIES(name, op) \
+ GEN_OP (name, op, uint8_t) \
+ GEN_OP (name, op, uint16_t) \
+ GEN_OP (name, op, uint32_t) \
+ GEN_OP (name, op, uint64_t) \
+ GEN_OP (name, op, int8_t) \
+ GEN_OP (name, op, int16_t) \
+ GEN_OP (name, op, int32_t) \
+ GEN_OP (name, op, int64_t) \
+ GEN_OP (name, op, float) \
+ GEN_OP (name, op, double)
+
+#define CO_ADD(l, r) ((l) + (r))
+#define CO_MIN(l, r) ((l) < (r) ? (l) : (r))
+#define CO_MAX(l, r) ((l) > (r) ? (l) : (r))
+GEN_OP_SERIES (sum, CO_ADD)
+GEN_OP_SERIES (min, CO_MIN)
+GEN_OP_SERIES (max, CO_MAX)
+
+// typedef void *(*opr_t) (void *, void *);
+typedef void *opr_t;
+
+#define GFC_DESCRIPTOR_KIND(desc) ((desc)->dtype.elem_len)
+
+#define CASE_TYPE_KIND(name, type, ctype) \
+ case type: \
+ { \
+ switch (GFC_DESCRIPTOR_KIND (desc)) \
+ { \
+ case 1: \
+ opr = (opr_t) name##_##ctype##8_t; \
+ break; \
+ case 2: \
+ opr = (opr_t) name##_##ctype##16_t; \
+ break; \
+ case 4: \
+ opr = (opr_t) name##_##ctype##32_t; \
+ break; \
+ case 8: \
+ opr = (opr_t) name##_##ctype##64_t; \
+ break; \
+ default: \
+ caf_runtime_error ("" #name \
+ " not available for type/kind combination"); \
+ } \
+ break; \
+ }
+
+#define SWITCH_TYPE_KIND(name) \
+ switch (GFC_DESCRIPTOR_TYPE (desc)) \
+ { \
+ CASE_TYPE_KIND (name, BT_INTEGER, int) \
+ CASE_TYPE_KIND (name, BT_UNSIGNED, uint) \
+ case BT_REAL: \
+ switch (GFC_DESCRIPTOR_KIND (desc)) \
+ { \
+ case 4: \
+ opr = (opr_t) name##_float; \
+ break; \
+ case 8: \
+ opr = (opr_t) name##_double; \
+ break; \
+ default: \
+ caf_runtime_error ("" #name \
+ " not available for type/kind combination"); \
+ } \
+ break; \
+ default: \
+ caf_runtime_error ("" #name " not available for type/kind combination"); \
+ }
+
+void
+_gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int mapped_index = -1, this_image_index;
+ opr_t opr;
+
+ if (stat)
+ *stat = 0;
+
+ /* 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,
+ NULL, stat))
+ return;
+
+ SWITCH_TYPE_KIND (sum)
+
+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);
+}
+
+void
+_gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int mapped_index = -1, this_image_index;
+ opr_t opr;
+
+ if (stat)
+ *stat = 0;
+ /* 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,
+ NULL, stat))
+ return;
+
+ SWITCH_TYPE_KIND (min)
+
+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);
+}
+
+void
+_gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int mapped_index = -1, this_image_index;
+ opr_t opr;
+
+ if (stat)
+ *stat = 0;
+ /* 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,
+ NULL, stat))
+ return;
+
+ SWITCH_TYPE_KIND (max)
+
+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);
+}
+
+void
+_gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *),
+ int opr_flags, int result_image, int *stat,
+ char *errmsg __attribute__ ((unused)), int desc_len,
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int mapped_index = -1, this_image_index;
+
+ if (stat)
+ *stat = 0;
+
+ /* 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,
+ NULL, stat))
+ return;
+
+ collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len);
+}
+
+void
+_gfortran_caf_register_accessor (const int hash, getter_t accessor)
+{
+ if (accessor_hash_table_state == AHT_UNINITIALIZED)
+ {
+ aht_cap = 16;
+ accessor_hash_table = calloc (aht_cap, sizeof (struct accessor_hash_t));
+ accessor_hash_table_state = AHT_OPEN;
+ }
+ if (aht_size == aht_cap)
+ {
+ aht_cap += 16;
+ accessor_hash_table = realloc (accessor_hash_table,
+ aht_cap * sizeof (struct accessor_hash_t));
+ }
+ if (accessor_hash_table_state == AHT_PREPARED)
+ {
+ accessor_hash_table_state = AHT_OPEN;
+ }
+ accessor_hash_table[aht_size].hash = hash;
+ accessor_hash_table[aht_size].u.getter = accessor;
+ ++aht_size;
+}
+
+static int
+hash_compare (const struct accessor_hash_t *lhs,
+ const struct accessor_hash_t *rhs)
+{
+ return lhs->hash < rhs->hash ? -1 : (lhs->hash > rhs->hash ? 1 : 0);
+}
+
+void
+_gfortran_caf_register_accessors_finish (void)
+{
+ if (accessor_hash_table_state == AHT_PREPARED
+ || accessor_hash_table_state == AHT_UNINITIALIZED)
+ return;
+
+ qsort (accessor_hash_table, aht_size, sizeof (struct accessor_hash_t),
+ (int (*) (const void *, const void *)) hash_compare);
+ accessor_hash_table_state = AHT_PREPARED;
+}
+
+int
+_gfortran_caf_get_remote_function_index (const int hash)
+{
+ if (accessor_hash_table_state != AHT_PREPARED)
+ {
+ caf_runtime_error ("the accessor hash table is not prepared.");
+ }
+
+ struct accessor_hash_t cand;
+ cand.hash = hash;
+ struct accessor_hash_t *f
+ = bsearch (&cand, accessor_hash_table, aht_size,
+ sizeof (struct accessor_hash_t),
+ (int (*) (const void *, const void *)) hash_compare);
+
+ int index = f ? f - accessor_hash_table : -1;
+ return index;
+}
+
+void
+_gfortran_caf_get_from_remote (
+ caf_token_t token, const gfc_descriptor_t *opt_src_desc,
+ const size_t *opt_src_charlen, const int image_index,
+ const size_t dst_size __attribute__ ((unused)), void **dst_data,
+ size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc,
+ const bool may_realloc_dst, const int getter_index, void *add_data,
+ const size_t add_data_size __attribute__ ((unused)), int *stat,
+ caf_team_t *team, int *team_number)
+{
+ caf_shmem_token_t shmem_token = TOKEN (token);
+ void *src_ptr;
+ int32_t free_buffer;
+ int remote_image_index, this_image_index;
+ void *dst_ptr = opt_dst_desc ? (void *)opt_dst_desc : dst_data;
+ void *old_dst_data_ptr = NULL, *old_src_data_ptr = NULL;
+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};
+
+ if (stat)
+ *stat = 0;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,
+ team, team_number, stat))
+ return;
+
+ /* Compute the address only after team's mapping has taken place. */
+ src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size;
+ if (opt_src_desc)
+ {
+ old_src_data_ptr = opt_src_desc->base_addr;
+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr;
+ src_ptr = (void *) opt_src_desc;
+ }
+
+ if (opt_dst_desc && !may_realloc_dst)
+ {
+ old_dst_data_ptr = opt_dst_desc->base_addr;
+ opt_dst_desc->base_addr = NULL;
+ }
+
+ accessor_hash_table[getter_index].u.getter (add_data, &image_index, dst_ptr,
+ &free_buffer, src_ptr, &cb_token,
+ 0, opt_dst_charlen,
+ opt_src_charlen);
+ if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst
+ && opt_dst_desc->base_addr != old_dst_data_ptr)
+ {
+ size_t dsize = opt_dst_desc->span;
+ for (int i = 0; i < GFC_DESCRIPTOR_RANK (opt_dst_desc); ++i)
+ dsize *= GFC_DESCRIPTOR_EXTENT (opt_dst_desc, i);
+ memcpy (old_dst_data_ptr, opt_dst_desc->base_addr, dsize);
+ free (opt_dst_desc->base_addr);
+ opt_dst_desc->base_addr = old_dst_data_ptr;
+ }
+
+ if (old_src_data_ptr)
+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr;
+}
+
+int32_t
+_gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,
+ const int present_index, void *add_data,
+ const size_t add_data_size
+ __attribute__ ((unused)))
+{
+ /* Unregistered tokens are always not present. */
+ if (!token)
+ return 0;
+
+ caf_shmem_token_t shmem_token = TOKEN (token);
+ int32_t result;
+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};
+ void *src_ptr, *arg;
+ int remote_image_index, this_image_index;
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_desc;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,
+ NULL, NULL, NULL))
+ return 0;
+
+ src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size;
+ if (shmem_token->desc)
+ {
+ memcpy (&temp_desc, shmem_token->desc,
+ sizeof (gfc_descriptor_t)
+ + GFC_DESCRIPTOR_RANK (shmem_token->desc)
+ * sizeof (descriptor_dimension));
+ temp_desc.base_addr = src_ptr;
+ arg = &temp_desc;
+ }
+ else
+ arg = &src_ptr;
+
+ accessor_hash_table[present_index].u.is_present (add_data, &image_index,
+ &result, arg, &cb_token, 0);
+
+ return result;
+}
+
+void
+_gfortran_caf_send_to_remote (
+ caf_token_t token, gfc_descriptor_t *opt_dst_desc,
+ const size_t *opt_dst_charlen, const int image_index,
+ const size_t src_size __attribute__ ((unused)), const void *src_data,
+ const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc,
+ const int accessor_index, void *add_data,
+ const size_t add_data_size __attribute__ ((unused)), int *stat,
+ caf_team_t *team, int *team_number)
+{
+ caf_shmem_token_t shmem_token = TOKEN (token);
+ void *dst_ptr, *dst_data_ptr, *old_dst_data_ptr = NULL;
+ const void *src_ptr = opt_src_desc ? (void *) opt_src_desc : src_data;
+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};
+ int remote_image_index, this_image_index;
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_src_desc;
+
+ if (stat)
+ *stat = 0;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,
+ team, team_number, stat))
+ return;
+
+ dst_data_ptr = dst_ptr
+ = shmem_token->base + remote_image_index * shmem_token->image_size;
+ if (opt_dst_desc)
+ {
+ old_dst_data_ptr = opt_dst_desc->base_addr;
+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr;
+ dst_ptr = (void *) opt_dst_desc;
+ }
+
+ /* Try to detect copy to self, with overlapping data segment. */
+ if (opt_src_desc && remote_image_index == this_image_index)
+ {
+ size_t src_data_span = GFC_DESCRIPTOR_SIZE (opt_src_desc);
+ for (int d = 0; d < GFC_DESCRIPTOR_RANK (opt_src_desc); d++)
+ src_data_span *= GFC_DESCRIPTOR_EXTENT (opt_src_desc, d);
+ if (GFC_DESCRIPTOR_DATA (opt_src_desc) >= dst_data_ptr
+ && dst_data_ptr <= GFC_DESCRIPTOR_DATA (opt_src_desc) + src_data_span)
+ {
+ src_ptr = __builtin_alloca (src_data_span);
+ if (!src_ptr)
+ {
+ caf_internal_error ("Out of stack in coarray send (dst[...] = "
+ "...) expression. Increase stacksize!",
+ stat, NULL, 0);
+ return;
+ }
+ memcpy ((void *) src_ptr, GFC_DESCRIPTOR_DATA (opt_src_desc),
+ src_data_span);
+ memcpy (&temp_src_desc, opt_src_desc,
+ sizeof (gfc_descriptor_t)
+ + sizeof (descriptor_dimension)
+ * GFC_DESCRIPTOR_RANK (opt_src_desc));
+ temp_src_desc.base_addr = (void *) src_ptr;
+ src_ptr = (void *) &temp_src_desc;
+ }
+ }
+
+ accessor_hash_table[accessor_index].u.receiver (add_data, &image_index,
+ dst_ptr, src_ptr, &cb_token,
+ 0, opt_dst_charlen,
+ opt_src_charlen);
+
+ if (old_dst_data_ptr)
+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr;
+}
+
+void
+_gfortran_caf_transfer_between_remotes (
+ caf_token_t dst_token, gfc_descriptor_t *opt_dst_desc,
+ size_t *opt_dst_charlen, const int dst_image_index,
+ const int dst_access_index, void *dst_add_data,
+ const size_t dst_add_data_size __attribute__ ((unused)),
+ caf_token_t src_token, const gfc_descriptor_t *opt_src_desc,
+ const size_t *opt_src_charlen, const int src_image_index,
+ const int src_access_index, void *src_add_data,
+ const size_t src_add_data_size __attribute__ ((unused)),
+ const size_t src_size, const bool scalar_transfer, int *dst_stat,
+ int *src_stat, caf_team_t *dst_team, int *dst_team_number,
+ caf_team_t *src_team, int *src_team_number)
+{
+ static const char *out_of_stack_errmsg
+ = "Out of stack in coarray transfer between remotes (dst[...] = "
+ "src[...]) expression. Increase stacksize!";
+ caf_shmem_token_t src_shmem_token = TOKEN (src_token),
+ dst_shmem_token = TOKEN (dst_token);
+ void *src_ptr, *old_src_data_ptr = NULL;
+ int32_t free_buffer;
+ void *dst_ptr, *old_dst_data_ptr = NULL;
+ void *transfer_ptr, *buffer;
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) *transfer_desc = NULL;
+ struct caf_shmem_token cb_token
+ = {src_add_data, NULL, src_add_data, 0, ~0, false};
+ int remote_image_index, this_image_index;
+
+ if (src_stat)
+ *src_stat = 0;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, src_image_index,
+ src_team, src_team_number, src_stat))
+ return;
+
+ if (!scalar_transfer)
+ {
+ const size_t desc_size = sizeof (*transfer_desc);
+ transfer_desc = __builtin_alloca (desc_size);
+ if (!transfer_desc)
+ {
+ caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0);
+ return;
+ }
+ memset (transfer_desc, 0, desc_size);
+ transfer_ptr = transfer_desc;
+ }
+ else if (opt_dst_charlen)
+ {
+ transfer_ptr = __builtin_alloca (*opt_dst_charlen * src_size);
+ if (!transfer_ptr)
+ {
+ caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0);
+ return;
+ }
+ }
+ else
+ {
+ buffer = NULL;
+ transfer_ptr = &buffer;
+ }
+
+ src_ptr
+ = src_shmem_token->base + remote_image_index * src_shmem_token->image_size;
+ if (opt_src_desc)
+ {
+ old_src_data_ptr = opt_src_desc->base_addr;
+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr;
+ src_ptr = (void *) opt_src_desc;
+ }
+
+ accessor_hash_table[src_access_index].u.getter (
+ src_add_data, &src_image_index, transfer_ptr, &free_buffer, src_ptr,
+ &cb_token, 0, opt_dst_charlen, opt_src_charlen);
+
+ if (old_src_data_ptr)
+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr;
+
+ if (dst_stat)
+ *dst_stat = 0;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, dst_image_index,
+ dst_team, dst_team_number, dst_stat))
+ return;
+
+ if (scalar_transfer)
+ transfer_ptr = *(void **) transfer_ptr;
+
+ dst_ptr
+ = dst_shmem_token->base + remote_image_index * dst_shmem_token->image_size;
+ if (opt_dst_desc)
+ {
+ old_dst_data_ptr = opt_dst_desc->base_addr;
+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr;
+ dst_ptr = (void *) opt_dst_desc;
+ }
+
+ cb_token.memptr = cb_token.base = dst_add_data;
+ accessor_hash_table[dst_access_index].u.receiver (dst_add_data,
+ &dst_image_index, dst_ptr,
+ transfer_ptr, &cb_token, 0,
+ opt_dst_charlen,
+ opt_src_charlen);
+
+ if (old_dst_data_ptr)
+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr;
+
+ if (free_buffer)
+ free (transfer_desc ? transfer_desc->base_addr : transfer_ptr);
+}
+
+#define GET_ATOM \
+ caf_shmem_token_t shmem_token = TOKEN (token); \
+ int remote_image_index, this_image_index; \
+ if (stat) \
+ *stat = 0; \
+ if (!image_index) \
+ image_index = this_image.image_num + 1; \
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index, \
+ NULL, NULL, stat)) \
+ return; \
+ assert (kind == 4); \
+ uint32_t *atom \
+ = (uint32_t *) (shmem_token->base \
+ + remote_image_index * shmem_token->image_size + offset)
+
+void
+_gfortran_caf_atomic_define (caf_token_t token, size_t offset, int image_index,
+ void *value, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ GET_ATOM;
+
+ __atomic_store (atom, (uint32_t *) value, __ATOMIC_SEQ_CST);
+}
+
+void
+_gfortran_caf_atomic_ref (caf_token_t token, size_t offset, int image_index,
+ void *value, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ GET_ATOM;
+
+ __atomic_load (atom, (uint32_t *) value, __ATOMIC_SEQ_CST);
+}
+
+void
+_gfortran_caf_atomic_cas (caf_token_t token, size_t offset, int image_index,
+ void *old, void *compare, void *new_val, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ GET_ATOM;
+
+ *(uint32_t *) old = *(uint32_t *) compare;
+ (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
+ *(uint32_t *) new_val, false,
+ __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);
+}
+
+void
+_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
+ int image_index, void *value, void *old, int *stat,
+ int type __attribute__ ((unused)), int kind)
+{
+ GET_ATOM;
+
+ uint32_t res;
+
+ switch (op)
+ {
+ case GFC_CAF_ATOMIC_ADD:
+ res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);
+ break;
+ case GFC_CAF_ATOMIC_AND:
+ res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);
+ break;
+ case GFC_CAF_ATOMIC_OR:
+ res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);
+ break;
+ case GFC_CAF_ATOMIC_XOR:
+ res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);
+ break;
+ default:
+ __builtin_unreachable ();
+ }
+
+ if (old)
+ *(uint32_t *) old = res;
+}
+
+#define GET_EVENT(token_, index_, image_index_) \
+ ((event_t *) (((caf_shmem_token_t) token_)->base \
+ + ((caf_shmem_token_t) token_)->image_size * image_index_ \
+ + sizeof (event_t) * index_))
+
+void
+_gfortran_caf_event_post (caf_token_t token, size_t index, int image_index,
+ int *stat, char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int remote_image_index, this_image_index;
+
+ if (stat)
+ *stat = 0;
+
+ /* When image_index is zero, access this image's event. */
+ if (!image_index)
+ image_index = this_image.image_num + 1;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,
+ NULL, NULL, stat))
+ return;
+
+ volatile event_t *event = GET_EVENT (token, index, remote_image_index);
+
+ lock_event (&local->si);
+ --(*event);
+ event_post (&local->si);
+ unlock_event (&local->si);
+}
+
+void
+_gfortran_caf_event_wait (caf_token_t token, size_t index, int until_count,
+ int *stat, char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ int remote_image_index, this_image_index;
+
+ if (stat)
+ *stat = 0;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, 1, NULL, NULL,
+ stat))
+ return;
+
+ volatile event_t *event = GET_EVENT (token, index, this_image_index);
+ event_t val;
+
+ lock_event (&local->si);
+ val = (*event += until_count);
+ if (val > 0) /* Move the invariant out of the loop. */
+ while (*event > 0)
+ event_wait (&local->si);
+ unlock_event (&local->si);
+
+ if (stat)
+ *stat = 0;
+}
+
+void
+_gfortran_caf_event_query (caf_token_t token, size_t index, int image_index,
+ int *count, int *stat)
+{
+ int remote_image_index, this_image_index;
+
+ if (stat)
+ *stat = 0;
+
+ /* When image_index is zero, access this image's event. */
+ if (!image_index)
+ image_index = this_image.image_num + 1;
+
+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,
+ NULL, NULL, stat))
+ return;
+
+ volatile event_t *event = GET_EVENT (token, index, remote_image_index);
+
+ lock_event (&local->si);
+ *count = *event;
+ unlock_event (&local->si);
+
+ if (*count < 0)
+ *count = -*count;
+}
+
+void
+_gfortran_caf_lock (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *acquired_lock, int *stat, char *errmsg,
+ size_t errmsg_len)
+{
+ const char *msg = "Already locked";
+ lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+ int res;
+
+ res
+ = acquired_lock ? pthread_mutex_trylock (lock) : pthread_mutex_lock (lock);
+
+ if (stat)
+ *stat = res == EBUSY ? GFC_STAT_LOCKED : 0;
+
+ if (acquired_lock)
+ {
+ *acquired_lock = (int) (res == 0);
+ return;
+ }
+
+ if (!res)
+ return;
+
+ if (stat)
+ {
+ if (errmsg_len > 0)
+ {
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
+ memcpy (errmsg, msg, len);
+ if (errmsg_len > len)
+ memset (&errmsg[len], ' ', errmsg_len-len);
+ }
+ return;
+ }
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
+}
+
+
+void
+_gfortran_caf_unlock (caf_token_t token, size_t index,
+ int image_index __attribute__ ((unused)),
+ int *stat, char *errmsg, size_t errmsg_len)
+{
+ const char *msg = "Variable is not locked";
+ lock_t *lock = &((lock_t *) MEMTOK (token))[index];
+ int res;
+
+ res = pthread_mutex_unlock (lock);
+
+ if (res == 0)
+ {
+ if (stat)
+ *stat = 0;
+ return;
+ }
+
+ if (stat && res == EPERM)
+ {
+ /* res == EPERM means that the lock is locked. Now figure, if by us by
+ trying to lock it or by other image, which fails. */
+ res = pthread_mutex_trylock (lock);
+ if (res == EBUSY)
+ *stat = GFC_STAT_LOCKED_OTHER_IMAGE;
+ else
+ {
+ *stat = GFC_STAT_UNLOCKED;
+ pthread_mutex_unlock (lock);
+ }
+
+ if (errmsg_len > 0)
+ {
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
+ memcpy (errmsg, msg, len);
+ if (errmsg_len > len)
+ memset (&errmsg[len], ' ', errmsg_len-len);
+ }
+ return;
+ }
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
+}
+
+
+/* Reference the libraries implementation. */
+extern void _gfortran_random_seed_i4 (int32_t *size, gfc_array_i4 *put,
+ gfc_array_i4 *get);
+
+void _gfortran_caf_random_init (bool repeatable, bool image_distinct)
+{
+ static struct
+ {
+ int32_t *base_addr;
+ size_t offset;
+ dtype_type dtype;
+ index_type span;
+ descriptor_dimension dim[1];
+ } rand_seed;
+ static bool rep_needs_init = true, arr_needs_init = true;
+ static int32_t seed_size;
+
+ if (arr_needs_init)
+ {
+ _gfortran_random_seed_i4 (&seed_size, NULL, NULL);
+ memset (&rand_seed, 0,
+ sizeof (gfc_array_i4) + sizeof (descriptor_dimension));
+ rand_seed.base_addr
+ = malloc (seed_size * sizeof (int32_t)); // because using seed_i4
+ rand_seed.offset = -1;
+ rand_seed.dtype.elem_len = sizeof (int32_t);
+ rand_seed.dtype.rank = 1;
+ rand_seed.dtype.type = BT_INTEGER;
+ rand_seed.span = 0;
+ rand_seed.dim[0].lower_bound = 1;
+ rand_seed.dim[0]._ubound = seed_size;
+ rand_seed.dim[0]._stride = 1;
+
+ arr_needs_init = false;
+ }
+
+ if (repeatable)
+ {
+ if (rep_needs_init)
+ {
+ int32_t lcg_seed = 57911963;
+ if (image_distinct)
+ {
+ lcg_seed *= this_image.image_num;
+ }
+ int32_t *curr = rand_seed.base_addr;
+ for (int i = 0; i < seed_size; ++i)
+ {
+ const int32_t a = 16087;
+ const int32_t m = INT32_MAX;
+ const int32_t q = 127773;
+ const int32_t r = 2836;
+ lcg_seed = a * (lcg_seed % q) - r * (lcg_seed / q);
+ if (lcg_seed <= 0)
+ lcg_seed += m;
+ *curr = lcg_seed;
+ ++curr;
+ }
+ rep_needs_init = false;
+ }
+ _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL);
+ }
+ else if (image_distinct)
+ {
+ _gfortran_random_seed_i4 (NULL, NULL, NULL);
+ }
+ else
+ {
+ if (this_image.image_num == 0)
+ {
+ _gfortran_random_seed_i4 (NULL, NULL, (gfc_array_i4 *) &rand_seed);
+ collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0);
+ }
+ else
+ {
+ collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0);
+ _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL);
+ }
+ }
+}
+
+void
+_gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,
+ int *stat, char *errmsg, size_t errmsg_len)
+{
+ const char new_index_out_of_range[]
+ = "The NEW_INDEX in a FORM TEAM has to in (0, num_images()].";
+ const char team_no_negativ[]
+ = "The team number in FORM TEAM has to be positive.";
+ const char alloc_fail_msg[] = "Failed to allocate team";
+ const char non_unique_image_ids[]
+ = "The NEW_INDEX of FORM TEAMs has to be unique.";
+ const char cannot_assign_index[]
+ = "Can not assign new image index in FORM TEAM.";
+ static int image_size_shift = -1;
+ static int teams_count = 0;
+ caf_shmem_team_t t;
+ bool created;
+ memid tmemid;
+
+ if (image_size_shift < 0)
+ image_size_shift = (int) round (log2 (local->total_num_images));
+ if (stat)
+ *stat = 0;
+
+ CHECK_TEAM_INTEGRITY (caf_current_team);
+
+ if (new_index
+ && (*new_index <= 0
+ || *new_index > caf_current_team->u.image_info->image_count.count))
+ {
+ caf_internal_error (new_index_out_of_range, stat, errmsg, errmsg_len);
+ return;
+ }
+ if (team_no <= 0)
+ {
+ caf_internal_error (team_no_negativ, stat, errmsg, errmsg_len);
+ return;
+ }
+
+ *team = malloc (sizeof (struct caf_shmem_team));
+ if (unlikely (*team == NULL))
+ {
+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
+ return;
+ }
+ t = *((caf_shmem_team_t *) team);
+
+ allocator_lock (&local->ai.alloc);
+ if (caf_current_team->team_no == -1)
+ tmemid = team_no + teams_count;
+ else
+ tmemid = (caf_current_team->u.image_info->lastmemid << image_size_shift)
+ + team_no + teams_count;
+ ++teams_count;
+ *t = (struct caf_shmem_team) {
+ caf_teams_formed,
+ team_no,
+ -1,
+ 0,
+ NULL,
+ {alloc_get_memory_by_id_created (
+ &local->ai,
+ sizeof (struct shmem_image_info)
+ + caf_current_team->u.image_info->image_count.count * sizeof (int),
+ -tmemid, &created)}};
+
+ if (created)
+ {
+ counter_barrier_init (&t->u.image_info->image_count, 0);
+ collsub_init_supervisor (&t->u.image_info->collsub,
+ alloc_get_allocator (&local->ai), 0);
+ t->u.image_info->team_parent_id = caf_current_team->team_no;
+ t->u.image_info->team_id = team_no;
+ t->u.image_info->image_map_size = 0;
+ t->u.image_info->num_term_images = 0;
+ t->u.image_info->lastmemid = tmemid;
+ /* Initialize a freshly created image_map with -1. */
+ for (int i = 0; i < caf_current_team->u.image_info->image_count.count;
+ ++i)
+ t->u.image_info->image_map[i] = -1;
+ }
+ counter_barrier_add (&t->u.image_info->image_count, 1);
+ counter_barrier_add (&t->u.image_info->collsub.barrier, 1);
+ allocator_unlock (&local->ai.alloc);
+
+ if (new_index)
+ {
+ int old_id;
+
+ t->index = *new_index - 1;
+ old_id = __atomic_exchange_n (&t->u.image_info->image_map[t->index],
+ this_image.image_num, __ATOMIC_SEQ_CST);
+ if (old_id != -1)
+ {
+ caf_internal_error (non_unique_image_ids, stat, errmsg, errmsg_len);
+ return;
+ }
+
+ __atomic_fetch_add (&t->u.image_info->image_map_size, 1,
+ __ATOMIC_SEQ_CST);
+ }
+ else
+ {
+ int im;
+ int exp = -1;
+
+ __atomic_fetch_add (&t->u.image_info->image_map_size, 1,
+ __ATOMIC_SEQ_CST);
+ sync_team (caf_current_team);
+
+ im = caf_current_team->index * t->u.image_info->image_map_size
+ / caf_current_team->u.image_info->image_count.count;
+ /* Map our old index into the domain of the new team's size. */
+ if (__atomic_compare_exchange_n (&t->u.image_info->image_map[im], &exp,
+ this_image.image_num, false,
+ __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST))
+ t->index = im;
+ else
+ {
+ caf_internal_error (cannot_assign_index, stat, errmsg, errmsg_len);
+ return;
+ }
+ }
+ sync_team (caf_current_team);
+
+ caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_change_team (caf_team_t team, int *stat,
+ char *errmsg __attribute__ ((unused)),
+ size_t errmsg_len __attribute__ ((unused)))
+{
+ caf_shmem_team_t t = (caf_shmem_team_t) team;
+
+ if (stat)
+ *stat = 0;
+
+ if (t == caf_teams_formed)
+ caf_teams_formed = t->parent;
+ else
+ for (caf_shmem_team_t p = caf_teams_formed; p; p = p->parent)
+ if (p->parent == t)
+ {
+ p->parent = t->parent;
+ break;
+ }
+
+ t->parent = caf_current_team;
+ t->parent_teams_last_active_memid = next_memid;
+ next_memid = (t->u.image_info->team_parent_id != -1
+ ? (((memid) t->u.image_info->team_parent_id) << 48)
+ : 0)
+ | (((memid) t->u.image_info->team_id) << 32) | 1;
+ caf_current_team = t;
+ sync_team (caf_current_team);
+}
+
+void
+_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)
+{
+ caf_shmem_team_t t = caf_current_team;
+
+ if (stat)
+ *stat = 0;
+
+ caf_current_team = caf_current_team->parent;
+ next_memid = t->parent_teams_last_active_memid;
+ sync_team (t);
+
+ for (struct coarray_allocated *ca = t->allocated; ca;)
+ {
+ struct coarray_allocated *nca = ca->next;
+ _gfortran_caf_deregister ((caf_token_t *) &ca->token,
+ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat,
+ errmsg, errmsg_len);
+ free (ca);
+ ca = nca;
+ }
+ t->allocated = NULL;
+ t->parent = caf_teams_formed;
+ caf_teams_formed = t;
+}
+
+void
+_gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg,
+ size_t errmsg_len)
+{
+ caf_shmem_team_t team_to_sync = (caf_shmem_team_t) team;
+ caf_shmem_team_t active_team = caf_current_team;
+
+ if (stat)
+ *stat = 0;
+
+ /* Check if team to sync is a child of the current team, aka not changed to
+ yet. */
+ if (team_to_sync->u.image_info->team_parent_id != active_team->team_no)
+ for (; active_team && active_team != team_to_sync;
+ active_team = active_team->parent)
+ ;
+
+ CHECK_TEAM_INTEGRITY (active_team);
+
+ if (!active_team)
+ {
+ caf_internal_error ("SYNC TEAM: Called on team different from current, "
+ "or ancestor, or child",
+ stat, errmsg, errmsg_len);
+ return;
+ }
+
+ sync_team (team_to_sync);
+}
+
+int
+_gfortran_caf_team_number (caf_team_t team)
+{
+ return team ? ((caf_shmem_team_t) team)->u.image_info->team_id
+ : caf_current_team->u.image_info->team_id;
+}
+
+caf_team_t
+_gfortran_caf_get_team (int32_t *level)
+{
+ if (!level)
+ return caf_current_team;
+
+ switch ((caf_team_level_t) *level)
+ {
+ case CAF_INITIAL_TEAM:
+ return caf_initial_team;
+ case CAF_PARENT_TEAM:
+ return caf_current_team->parent ? caf_current_team->parent
+ : caf_current_team;
+ case CAF_CURRENT_TEAM:
+ return caf_current_team;
+ default:
+ caf_runtime_error ("Illegal value for GET_TEAM");
+ }
+ return NULL; /* To prevent any warnings. */
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+/* This provides the coarray-specific features (like IDs etc) for
+ allocator.c, in turn calling routines from shared_memory.c.
+*/
+
+#include "alloc.h"
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "shared_memory.h"
+
+#include <assert.h>
+#include <pthread.h>
+#include <string.h>
+
+/* Worker's part to initialize the alloc interface. */
+
+void
+alloc_init (alloc *iface, shared_memory mem)
+{
+ iface->as = &this_image.supervisor->alloc_shared;
+ iface->mem = mem;
+ allocator_init (&iface->alloc, &iface->as->allocator_s, mem);
+ hashmap_init (&iface->hm, &this_image.supervisor->hms, &iface->alloc);
+}
+
+/* Allocate the shared memory interface. This is called before we have
+ multiple images. Called only by supervisor. */
+
+void
+alloc_init_supervisor (alloc *iface, shared_memory mem)
+{
+ iface->as = &this_image.supervisor->alloc_shared;
+ iface->mem = mem;
+ allocator_init_supervisor (&iface->alloc, &iface->as->allocator_s, mem);
+ hashmap_init_supervisor (&iface->hm, &this_image.supervisor->hms,
+ &iface->alloc);
+}
+
+/* Return a local pointer into a shared memory object identified by
+ id. If the object is already found, it has been allocated before,
+ so just increase the reference counter.
+
+ The pointers returned by this function remain valid even if the
+ size of the memory allocation changes (see shared_memory.c). */
+
+static void *
+get_memory_by_id_internal (alloc *iface, size_t size, memid id, bool *created)
+{
+ hashmap_search_result res;
+ shared_mem_ptr shared_ptr;
+ void *ret;
+
+ shared_memory_prepare (iface->mem);
+
+ res = hashmap_get (&iface->hm, id);
+
+ if (hm_search_result_contains (&res))
+ {
+ size_t found_size;
+ found_size = hm_search_result_size (&res);
+ if (found_size < size)
+ {
+ allocator_unlock (&iface->alloc);
+ caf_runtime_error (
+ "Size mismatch for coarray allocation id %zd: found = %lu "
+ "< size = %lu\n",
+ id, found_size, size);
+ return NULL; // The runtime_error exit()s, so this is never reached.
+ }
+ shared_ptr = hm_search_result_ptr (&res);
+ hashmap_inc (&iface->hm, id, &res);
+
+ if (created)
+ *created = false;
+ ret = SHMPTR_AS (void *, shared_ptr, iface->mem);
+ }
+ else
+ {
+ shared_ptr = allocator_shared_malloc (&iface->alloc, size);
+ hashmap_set (&iface->hm, id, NULL, shared_ptr, size);
+
+ if (created)
+ *created = true;
+
+ ret = SHMPTR_AS (void *, shared_ptr, iface->mem);
+ }
+
+ return ret;
+}
+
+void *
+alloc_get_memory_by_id (alloc *iface, size_t size, memid id)
+{
+ allocator_lock (&iface->alloc);
+ void *ret = get_memory_by_id_internal (iface, size, id, NULL);
+ allocator_unlock (&iface->alloc);
+ return ret;
+}
+
+void *
+alloc_get_memory_by_id_created (alloc *iface, size_t size, memid id,
+ bool *created)
+{
+ return get_memory_by_id_internal (iface, size, id, created);
+}
+
+
+/* Free memory with id. Free it if this is the last image which
+ holds that memory segment, decrease the reference count otherwise. */
+
+void
+alloc_free_memory_with_id (alloc *iface, memid id)
+{
+ hashmap_search_result res;
+ int entries_left;
+
+ allocator_lock (&iface->alloc);
+ shared_memory_prepare (iface->mem);
+
+ res = hashmap_get (&iface->hm, id);
+ if (!hm_search_result_contains (&res))
+ {
+ allocator_unlock (&iface->alloc);
+ caf_runtime_error ("Error in free_memory_with_id: %zd not found.\n", id);
+ return;
+ }
+
+ entries_left = hashmap_dec (&iface->hm, id, &res);
+ assert (entries_left >= 0);
+
+ if (entries_left == 0)
+ {
+ allocator_shared_free (&iface->alloc, hm_search_result_ptr (&res),
+ hm_search_result_size (&res));
+ }
+
+ allocator_unlock (&iface->alloc);
+ return;
+}
+
+allocator *
+alloc_get_allocator (alloc *iface)
+{
+ return &iface->alloc;
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef ALLOC_H
+#define ALLOC_H
+
+#include "allocator.h"
+#include "hashmap.h"
+
+/* High-level interface for shared memory allocation.
+ Handle allocation and freeing of blocks in the shared memory for coarrays.
+ While allocator keeps track of allocated and freeed portions, this "class"
+ allows allocation of coarrays identified by a memid and associate them
+ across images.
+ */
+
+/* The part of the alloc interface being shared with all other images. There
+ must be only one of these objects! */
+typedef struct alloc_shared
+{
+ allocator_shared allocator_s;
+} alloc_shared;
+
+/* This is the image's local part of the alloc interface. */
+
+typedef struct alloc
+{
+ alloc_shared *as;
+ shared_memory mem;
+ allocator alloc;
+ hashmap hm;
+} alloc;
+
+/* Initialize the local instance of the alloc interface. This routine is to be
+ called by every worker image and NOT by the supervisor. */
+void alloc_init (alloc *, shared_memory);
+
+/* The routine MUST ONLY called by the supervisor process.
+ Initialize the shared part of the alloc interface. The local one is only
+ initialized to be able to pass it to the other components needing it. */
+void alloc_init_supervisor (alloc *, shared_memory);
+
+/* Get a shared memory block identified by id, or a new one, when the id
+ is not known yet. This routine locks the allocator lock itself. */
+void *alloc_get_memory_by_id (alloc *, size_t, memid);
+
+/* Same as alloc_get_memory_by_id, but it does not lock the allocator lock and
+ returns an additional bool, that is true, when the memory has been allocated
+ freshly. */
+void *alloc_get_memory_by_id_created (alloc *, size_t, memid, bool *);
+
+/* Mark the memory identified by id as free. This reduces the use counter on
+ the memory and sets is free, when the count goes to zero. */
+void alloc_free_memory_with_id (alloc *, memid);
+
+/* Get the allocator for reuse in other interfaces. */
+allocator *alloc_get_allocator (alloc *);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+/* Main allocation routine, works like malloc. Round up allocations
+ to the next power of two and keep free lists in buckets. */
+
+#include "libgfortran.h"
+
+#include "allocator.h"
+#include "supervisor.h"
+#include "thread_support.h"
+
+#include <assert.h>
+
+typedef struct
+{
+ shared_mem_ptr next;
+} bucket;
+
+size_t
+alignto (size_t size, size_t align)
+{
+ return align * ((size + align - 1) / align);
+}
+
+size_t pagesize;
+
+size_t
+round_to_pagesize (size_t s)
+{
+ return alignto (s, pagesize);
+}
+
+/* Initialize the allocator. */
+
+void
+allocator_init (allocator *a, allocator_shared *s, shared_memory sm)
+{
+ *a = (allocator) {s, sm};
+}
+
+void
+allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm)
+{
+ *a = (allocator) {s, sm};
+ initialize_shared_mutex (&s->lock);
+ for (size_t i = 0; i < VOIDP_BITS; i++)
+ s->free_bucket_head[i] = SHMPTR_NULL;
+}
+
+#define MAX_ALIGN 16
+
+static size_t
+next_power_of_two (size_t size)
+{
+ assert (size);
+ return 1 << (VOIDP_BITS - __builtin_clzl (size - 1));
+}
+
+shared_mem_ptr
+allocator_shared_malloc (allocator *a, size_t size)
+{
+ shared_mem_ptr ret;
+ size_t sz;
+ size_t act_size;
+ int bucket_list_index;
+
+ sz = next_power_of_two (size);
+ act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);
+ bucket_list_index = __builtin_clzl (act_size);
+
+ if (SHMPTR_IS_NULL (a->s->free_bucket_head[bucket_list_index]))
+ return shared_memory_get_mem_with_alignment (a->shm, act_size, MAX_ALIGN);
+
+ ret = a->s->free_bucket_head[bucket_list_index];
+ a->s->free_bucket_head[bucket_list_index]
+ = (SHMPTR_AS (bucket *, ret, a->shm)->next);
+ return ret;
+}
+
+/* Free memory. */
+
+void
+allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size)
+{
+ bucket *b;
+ size_t sz;
+ int bucket_list_index;
+ size_t act_size;
+
+ sz = next_power_of_two (size);
+ act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);
+ bucket_list_index = __builtin_clzl (act_size);
+
+ b = SHMPTR_AS (bucket *, p, a->shm);
+ b->next = a->s->free_bucket_head[bucket_list_index];
+ a->s->free_bucket_head[bucket_list_index] = p;
+}
+
+void
+allocator_lock (allocator *a)
+{
+ pthread_mutex_lock (&a->s->lock);
+}
+
+void
+allocator_unlock (allocator *a)
+{
+ pthread_mutex_unlock (&a->s->lock);
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+/* A malloc() - and free() - like interface, but for shared memory
+ pointers, except that we pass the size to free as well. */
+
+#ifndef ALLOCATOR_HDR
+#define ALLOCATOR_HDR
+
+#include "shared_memory.h"
+
+#include <stddef.h>
+#include <pthread.h>
+
+/* The number of bits a void pointer has. */
+#define VOIDP_BITS (__CHAR_BIT__ * sizeof (void *))
+
+/* The shared memory part of the allocator. */
+typedef struct {
+ pthread_mutex_t lock;
+ shared_mem_ptr free_bucket_head[VOIDP_BITS];
+} allocator_shared;
+
+/* The image local part of the allocator. */
+typedef struct {
+ allocator_shared *s;
+ shared_memory shm;
+} allocator;
+
+/* The size of a page on this architecture. */
+extern size_t pagesize;
+
+/* Helper routine to align a size to a given boundary. */
+size_t alignto (size_t, size_t);
+
+/* Helper routine to round a size to multiple of the architecture's pagesize.
+ */
+size_t round_to_pagesize (size_t);
+
+/* Link the worker's allocator with the part in the shared memory. */
+void allocator_init (allocator *, allocator_shared *, shared_memory);
+
+/* Initialize the allocator. This MUST be called ONLY be the supervisor and
+ only once! */
+void allocator_init_supervisor (allocator *, allocator_shared *, shared_memory);
+
+/* Request a block of shared memory. The memory is not linked with the other
+ images. The shared_mem_ptr returned is only local to the calling image.
+ When requiring a memory block shared between all images, call
+ alloc_get_memory_by_id...(). */
+shared_mem_ptr allocator_shared_malloc (allocator *, size_t size);
+
+/* Free the given piece of memory. This routine just inserts the memory chunk
+ into the bucket list of free memory. It does not join adjacent blocks of
+ memory (not implemented yet). */
+void allocator_shared_free (allocator *, shared_mem_ptr, size_t size);
+
+/* Lock the allocator lock preventing any image from modifying memory management
+ structures. Do not forget to unlock. This interface is exposed to be able
+ to do more then just get the memory without having to introduce a second lock
+ and the problems with having to get both. */
+void allocator_lock (allocator *);
+
+/* Unlock the allocator lock. */
+void allocator_unlock (allocator *);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "collective_subroutine.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <string.h>
+
+/* Usage:
+ pack_info pi;
+ packed = pack_array_prepare (&pi, source);
+
+ // Awesome allocation of destptr using pi.num_elem
+ if (packed)
+ memcpy (...);
+ else
+ pack_array_finish (&pi, source, destptr);
+
+This could also be used in in_pack_generic.c. Additionally, since
+pack_array_prepare is the same for all type sizes, we would only have to
+specialize pack_array_finish, saving on code size. */
+
+typedef struct
+{
+ index_type num_elem;
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS]; /* Stride is byte-based. */
+} pack_info;
+
+static bool
+pack_array_prepare (pack_info *pi, const gfc_descriptor_t *source)
+{
+ index_type dim;
+ bool packed;
+ index_type span;
+ index_type type_size;
+ index_type ssize;
+
+ dim = GFC_DESCRIPTOR_RANK (source);
+ type_size = GFC_DESCRIPTOR_SIZE (source);
+ ssize = type_size;
+
+ pi->num_elem = 1;
+ packed = true;
+ span = source->span != 0 ? source->span : type_size;
+ for (index_type n = 0; n < dim; n++)
+ {
+ pi->stride[n] = GFC_DESCRIPTOR_STRIDE (source, n) * span;
+ pi->extent[n] = GFC_DESCRIPTOR_EXTENT (source, n);
+ if (pi->extent[n] <= 0)
+ {
+ /* Do nothing. */
+ packed = true;
+ pi->num_elem = 0;
+ break;
+ }
+
+ if (ssize != pi->stride[n])
+ packed = false;
+
+ pi->num_elem *= pi->extent[n];
+ ssize *= pi->extent[n];
+ }
+
+ return packed;
+}
+
+static void
+pack_array_finish (const pack_info *pi, const gfc_descriptor_t *source,
+ char *dest)
+{
+ index_type dim;
+ const char *restrict src;
+
+ index_type size;
+ index_type stride0;
+ index_type count[GFC_MAX_DIMENSIONS];
+
+ dim = GFC_DESCRIPTOR_RANK (source);
+ src = source->base_addr;
+ stride0 = pi->stride[0];
+ size = GFC_DESCRIPTOR_SIZE (source);
+ memset (count, '\0', sizeof (index_type) * dim);
+ while (src)
+ {
+ /* Copy the data. */
+ memcpy (dest, src, size);
+ /* Advance to the next element. */
+ dest += size;
+ src += stride0;
+ count[0]++;
+ /* Advance to the next source element. */
+ index_type n = 0;
+ while (count[n] == pi->extent[n])
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ src -= pi->stride[n] * pi->extent[n];
+ n++;
+ if (n == dim)
+ {
+ src = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ src += pi->stride[n];
+ }
+ }
+ }
+}
+
+static void
+unpack_array_finish (const pack_info *pi, const gfc_descriptor_t *d,
+ const void *src)
+{
+ index_type stride0;
+ char *restrict dest;
+ index_type size;
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type dim;
+
+ size = GFC_DESCRIPTOR_SIZE (d);
+ stride0 = pi->stride[0];
+ dest = d->base_addr;
+ dim = GFC_DESCRIPTOR_RANK (d);
+
+ memset (count, '\0', sizeof (index_type) * dim);
+ while (dest)
+ {
+ memcpy (dest, src, size);
+ src += size;
+ dest += stride0;
+ count[0]++;
+ index_type n = 0;
+ while (count[n] == pi->extent[n])
+ {
+ count[n] = 0;
+ dest -= pi->stride[n] * pi->extent[n];
+ n++;
+ if (n == dim)
+ {
+ dest = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ dest += pi->stride[n];
+ }
+ }
+ }
+}
+
+void
+collsub_init_supervisor (collsub_shared *cis, allocator *al,
+ const int init_num_images)
+{
+ /* Choose an arbitrary large buffer. It can grow later if needed. */
+ const size_t init_size = 1U << 10;
+
+ cis->curr_size = init_size;
+ cis->collsub_buf = allocator_shared_malloc (al, init_size);
+
+ counter_barrier_init (&cis->barrier, init_num_images);
+ initialize_shared_mutex (&cis->mutex);
+}
+
+static void *
+get_collsub_buf (size_t size)
+{
+ void *ret;
+
+ pthread_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);
+ /* curr_size is always at least sizeof(double), so we don't need to worry
+ about size == 0. */
+ if (size > caf_current_team->u.image_info->collsub.curr_size)
+ {
+ allocator_shared_free (
+ alloc_get_allocator (&local->ai),
+ caf_current_team->u.image_info->collsub.collsub_buf,
+ caf_current_team->u.image_info->collsub.curr_size);
+ caf_current_team->u.image_info->collsub.collsub_buf
+ = allocator_shared_malloc (alloc_get_allocator (&local->ai), size);
+ caf_current_team->u.image_info->collsub.curr_size = size;
+ }
+
+ ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,
+ &local->sm);
+ pthread_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);
+ return ret;
+}
+
+/* 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);
+}
+
+typedef void *(*red_op) (void *, void *);
+typedef void (*ass_op) (red_op, void *, void *, size_t);
+
+#define GEN_FOR_BITS(BITS) \
+ static void assign_##BITS (void *op, uint##BITS##_t *lhs, \
+ uint##BITS##_t *rhs, size_t) \
+ { \
+ *lhs \
+ = ((uint##BITS##_t (*) (uint##BITS##_t *, uint##BITS##_t *)) op) (lhs, \
+ rhs); \
+ } \
+ static void assign_by_val_##BITS (void *op, uint##BITS##_t *lhs, \
+ uint##BITS##_t *rhs, size_t) \
+ { \
+ *lhs = ((uint##BITS##_t (*) (uint##BITS##_t, uint##BITS##_t)) op) (*lhs, \
+ *rhs); \
+ }
+
+GEN_FOR_BITS (8)
+GEN_FOR_BITS (16)
+GEN_FOR_BITS (32)
+GEN_FOR_BITS (64)
+// GEN_FOR_BITS (128)
+
+static void
+assign_float (void *op, float *lhs, float *rhs, size_t)
+{
+ *lhs = ((float (*) (float *, float *)) op) (lhs, rhs);
+}
+
+static void
+assign_double (void *op, double *lhs, double *rhs, size_t)
+{
+ *lhs = ((double (*) (double *, double *)) op) (lhs, rhs);
+}
+
+static void
+assign_var (red_op op, void *lhs, void *rhs, size_t sz)
+{
+ memcpy (lhs, op (lhs, rhs), sz);
+}
+
+static void
+assign_char (void *op, void *lhs, void *rhs, size_t sz)
+{
+ ((void (*) (char *, size_t, char *, char *, size_t,
+ size_t)) op) (lhs, sz, lhs, rhs, sz, sz);
+}
+
+static ass_op
+gen_reduction (const int type, const size_t sz, const int flags)
+{
+ const bool by_val = flags & GFC_CAF_ARG_VALUE;
+ switch (type)
+ {
+ case BT_CHARACTER:
+ return (ass_op) assign_char;
+ case BT_REAL:
+ switch (sz)
+ {
+ case 4:
+ return (ass_op) assign_float;
+ case 8:
+ return (ass_op) assign_double;
+ default:
+ return assign_var;
+ }
+ default:
+ switch (sz)
+ {
+ case 1:
+ return (ass_op) (by_val ? assign_by_val_8 : assign_8);
+ case 2:
+ return (ass_op) (by_val ? assign_by_val_16 : assign_16);
+ case 4:
+ return (ass_op) (by_val ? assign_by_val_32 : assign_32);
+ case 8:
+ return (ass_op) (by_val ? assign_by_val_64 : assign_64);
+ // case 16:
+ // return assign_128;
+ default:
+ return assign_var;
+ }
+ }
+}
+
+/* Having result_image == -1 means allreduce. */
+
+void
+collsub_reduce_array (gfc_descriptor_t *desc, int result_image,
+ void *(*op) (void *, void *), int opr_flags,
+ int str_len __attribute__ ((unused)))
+{
+ void *buffer;
+ pack_info pi;
+ bool packed;
+ int cbit = 0;
+ int imoffset;
+ index_type elem_size;
+ index_type this_image_size_bytes;
+ void *this_image_buf, *roll_iter, *src_iter;
+ ass_op assign;
+ const int this_img_id = caf_current_team->index;
+
+ packed = pack_array_prepare (&pi, desc);
+ if (pi.num_elem == 0)
+ return;
+
+ elem_size = GFC_DESCRIPTOR_SPAN (desc);
+ this_image_size_bytes = elem_size * pi.num_elem;
+
+ buffer = get_collsub_buf (
+ this_image_size_bytes * caf_current_team->u.image_info->image_count.count);
+ this_image_buf = buffer + this_image_size_bytes * this_img_id;
+
+ if (packed)
+ memcpy (this_image_buf, GFC_DESCRIPTOR_DATA (desc), this_image_size_bytes);
+ else
+ pack_array_finish (&pi, desc, this_image_buf);
+
+ assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags);
+ collsub_sync ();
+
+ for (; ((this_img_id >> cbit) & 1) == 0
+ && (caf_current_team->u.image_info->image_count.count >> cbit) != 0;
+ cbit++)
+ {
+ imoffset = 1 << cbit;
+ if (this_img_id + imoffset
+ < caf_current_team->u.image_info->image_count.count)
+ {
+ /* Reduce arrays elementwise. */
+ roll_iter = this_image_buf;
+ src_iter = this_image_buf + this_image_size_bytes * imoffset;
+ for (ssize_t i = 0; i < pi.num_elem;
+ ++i, roll_iter += elem_size, src_iter += elem_size)
+ assign (op, roll_iter, src_iter, elem_size);
+ }
+ collsub_sync ();
+ }
+ for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0;
+ cbit++)
+ collsub_sync ();
+
+ if (result_image < 0 || result_image == this_image.image_num)
+ {
+ if (packed)
+ memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, this_image_size_bytes);
+ else
+ unpack_array_finish (&pi, desc, buffer);
+ }
+
+ collsub_sync ();
+}
+
+/* Do not use sync_all(), because the program should deadlock in the case that
+ * some images are on a sync_all barrier while others are in a collective
+ * subroutine. */
+
+void
+collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)
+{
+ void *buffer;
+ pack_info pi;
+ bool packed;
+ index_type elem_size;
+ index_type size_bytes;
+
+ packed = pack_array_prepare (&pi, desc);
+ if (pi.num_elem == 0)
+ return;
+
+ if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER)
+ {
+ if (GFC_DESCRIPTOR_SIZE (desc))
+ elem_size = GFC_DESCRIPTOR_SIZE (desc);
+ else
+ elem_size = strlen (desc->base_addr);
+ }
+ else
+ elem_size = GFC_DESCRIPTOR_SPAN (desc) != 0
+ ? ((index_type) GFC_DESCRIPTOR_SPAN (desc))
+ : ((index_type) GFC_DESCRIPTOR_SIZE (desc));
+ size_bytes = elem_size * pi.num_elem;
+ buffer = get_collsub_buf (size_bytes);
+
+ if (source_image == this_image.image_num)
+ {
+ if (packed)
+ memcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes);
+ else
+ pack_array_finish (&pi, desc, buffer);
+ collsub_sync ();
+ }
+ else
+ {
+ collsub_sync ();
+ if (packed)
+ memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes);
+ else
+ unpack_array_finish (&pi, desc, buffer);
+ }
+
+ collsub_sync ();
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef COLLECTIVE_SUBROUTINE_HDR
+#define COLLECTIVE_SUBROUTINE_HDR
+
+#include "alloc.h"
+#include "counter_barrier.h"
+#include "shared_memory.h"
+
+#include "caf/libcaf.h"
+
+typedef struct collsub_shared
+{
+ size_t curr_size;
+ shared_mem_ptr collsub_buf;
+ counter_barrier barrier;
+ pthread_mutex_t mutex;
+} collsub_shared;
+
+void collsub_init_supervisor (collsub_shared *, allocator *,
+ const int init_num_images);
+
+void collsub_broadcast_array (gfc_descriptor_t *, int);
+
+void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *),
+ int opr_flags, int str_len);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "libgfortran.h"
+#include "counter_barrier.h"
+#include "supervisor.h"
+#include "thread_support.h"
+
+#include <assert.h>
+
+/* Lock the associated counter of this barrier. */
+
+static inline void
+lock_counter_barrier (counter_barrier *b)
+{
+ pthread_mutex_lock (&b->mutex);
+}
+
+/* Unlock the associated counter of this barrier. */
+
+static inline void
+unlock_counter_barrier (counter_barrier *b)
+{
+ pthread_mutex_unlock (&b->mutex);
+}
+
+void
+counter_barrier_init (counter_barrier *b, int val)
+{
+ *b = (counter_barrier) {PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER,
+ val, 0, val};
+ initialize_shared_condition (&b->cond);
+ initialize_shared_mutex (&b->mutex);
+}
+
+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)
+ pthread_cond_broadcast (&b->cond);
+ else
+ {
+ while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
+ pthread_cond_wait (&b->cond, &b->mutex);
+ }
+
+ if (b->wait_count <= 0)
+ {
+ b->curr_wait_group = !wait_group_beginning;
+ b->wait_count = b->count;
+ }
+
+ unlock_counter_barrier (b);
+}
+
+
+static inline void
+change_internal_barrier_count (counter_barrier *b, int val)
+{
+ b->wait_count += val;
+ if (b->wait_count <= 0)
+ pthread_cond_broadcast (&b->cond);
+}
+
+int
+counter_barrier_add_locked (counter_barrier *c, int val)
+{
+ int ret;
+ ret = (c->count += val);
+ change_internal_barrier_count (c, val);
+
+ return ret;
+}
+
+int
+counter_barrier_add (counter_barrier *c, int val)
+{
+ int ret;
+ pthread_mutex_lock (&c->mutex);
+ ret = counter_barrier_add_locked (c, val);
+
+ pthread_mutex_unlock (&c->mutex);
+ return ret;
+}
+
+int
+counter_barrier_get_count (counter_barrier *c)
+{
+ int ret;
+ pthread_mutex_lock (&c->mutex);
+ ret = c->count;
+ pthread_mutex_unlock (&c->mutex);
+ return ret;
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef COUNTER_BARRIER_HDR
+#define COUNTER_BARRIER_HDR
+
+#include <pthread.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
+ calls to counter_barrier_wait() will sync the given number of images. There
+ is no order in which the images will be woken up from their wait.
+ Furthermore may this "class" be used as a event queue counter. To use it in
+ that way the counter barrier is to be initialized with zero. Every "add" to
+ the queue then is to be made by incrementing the counter_barrier every take
+ by decrementing the queue. If the queue does not satiesfy the needed number
+ of entries they can be waited for.
+ */
+
+typedef struct
+{
+ pthread_mutex_t mutex;
+ pthread_cond_t cond;
+ volatile int wait_count;
+ volatile int curr_wait_group;
+ volatile int count;
+} counter_barrier;
+
+/* Initialize the counter barrier. Only to be called once per counter barrier.
+ I.e. a counter barrier in shared memory must only be initialized by one
+ image. */
+
+void counter_barrier_init (counter_barrier *, int);
+
+/* Add the given number to the counter barrier. This signals waiting images
+ when the count drops below 0. This routine is only to be called, when the
+ image has taken the counter barrier's lock by some other way. */
+
+int counter_barrier_add_locked (counter_barrier *, int);
+
+/* Add the given number to the counter barrier. This signals waiting images
+ when the count drops below 0. */
+
+int counter_barrier_add (counter_barrier *, int);
+
+/* Get the count of the barrier. */
+
+int counter_barrier_get_count (counter_barrier *);
+
+/* Wait for the count in the barrier drop to or below 0. */
+
+void counter_barrier_wait (counter_barrier *);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "libgfortran.h"
+
+#include "hashmap.h"
+
+#include <string.h>
+
+#define INITIAL_BITNUM (5)
+#define INITIAL_SIZE (1 << INITIAL_BITNUM)
+#define CRITICAL_LOOKAHEAD (16)
+
+static ssize_t n_ent;
+
+typedef struct
+{
+ memid id;
+ shared_mem_ptr p; /* If p == SHMPTR_NULL, the entry is empty. */
+ size_t s;
+ int max_lookahead;
+ int refcnt;
+} hashmap_entry;
+
+/* 64 bit to 64 bit hash function. */
+
+static inline uint64_t
+hash (uint64_t key)
+{
+ key ^= (key >> 30);
+ key *= 0xbf58476d1ce4e5b9ul;
+ key ^= (key >> 27);
+ key *= 0x94d049bb133111ebul;
+ key ^= (key >> 31);
+
+ return key;
+}
+
+/* Gets a pointer to the current data in the hashmap. */
+
+static inline hashmap_entry *
+get_data (hashmap *hm)
+{
+ return SHMPTR_AS (hashmap_entry *, hm->s->data, hm->sm);
+}
+
+/* Generate mask from current number of bits. */
+
+static inline intptr_t
+gen_mask (hashmap *hm)
+{
+ return (1 << hm->s->bitnum) - 1;
+}
+
+/* Add with wrap-around at hashmap size. */
+
+static inline size_t
+hmiadd (hashmap *hm, size_t s, ssize_t o)
+{
+ return (s + o) & gen_mask (hm);
+}
+
+/* Get the expected offset for entry id. */
+
+static inline ssize_t
+get_expected_offset (hashmap *hm, memid id)
+{
+ return hash (id) >> (VOIDP_BITS - hm->s->bitnum);
+}
+
+/* Initialize the hashmap. */
+
+void
+hashmap_init (hashmap *hm, hashmap_shared *hs, allocator *a)
+{
+ *hm = (hashmap) {hs, a->shm, a};
+}
+
+void
+hashmap_init_supervisor (hashmap *hm, hashmap_shared *hs, allocator *a)
+{
+ hashmap_entry *data;
+ *hm = (hashmap) {hs, a->shm, a};
+ hm->s->data
+ = allocator_shared_malloc (a, INITIAL_SIZE * sizeof (hashmap_entry));
+ data = get_data (hm);
+ memset (data, '\0', INITIAL_SIZE * sizeof (hashmap_entry));
+
+ hm->s->size = INITIAL_SIZE;
+ hm->s->bitnum = INITIAL_BITNUM;
+}
+
+/* This checks if the entry id exists in that range the range between
+ the expected position and the maximum lookahead. */
+
+static ssize_t
+scan_inside_lookahead (hashmap *hm, ssize_t expected_off, memid id)
+{
+ ssize_t lookahead;
+ hashmap_entry *data;
+
+ data = get_data (hm);
+ lookahead = data[expected_off].max_lookahead;
+
+ for (int i = 0; i <= lookahead; i++) /* For performance, this could
+ iterate backwards. */
+ if (data[hmiadd (hm, expected_off, i)].id == id)
+ return hmiadd (hm, expected_off, i);
+
+ return -1;
+}
+
+/* Scan for the next empty slot we can use. Returns offset relative
+ to the expected position. */
+
+static ssize_t
+scan_empty (hashmap *hm, ssize_t expected_off)
+{
+ hashmap_entry *data;
+
+ data = get_data (hm);
+ for (int i = 0; i < CRITICAL_LOOKAHEAD; i++)
+ if (SHMPTR_IS_NULL (data[hmiadd (hm, expected_off, i)].p))
+ return i;
+
+ return -1;
+}
+
+/* Search the hashmap for id. */
+
+hashmap_search_result
+hashmap_get (hashmap *hm, memid id)
+{
+ hashmap_search_result ret;
+ hashmap_entry *data;
+ size_t expected_offset;
+ ssize_t res;
+
+ data = get_data (hm);
+ expected_offset = get_expected_offset (hm, id);
+ res = scan_inside_lookahead (hm, expected_offset, id);
+
+ if (res != -1)
+ ret = ((hashmap_search_result){
+ .p = data[res].p, .size = data[res].s, .res_offset = res });
+ else
+ ret.p = SHMPTR_NULL;
+
+ return ret;
+}
+
+/* Return size of a hashmap search result. */
+
+size_t
+hm_search_result_size (hashmap_search_result *res)
+{
+ return res->size;
+}
+
+/* Return pointer of a hashmap search result. */
+
+shared_mem_ptr
+hm_search_result_ptr (hashmap_search_result *res)
+{
+ return res->p;
+}
+
+/* Return pointer of a hashmap search result. */
+
+bool
+hm_search_result_contains (hashmap_search_result *res)
+{
+ return !SHMPTR_IS_NULL (res->p);
+}
+
+/* Enlarge hashmap memory. */
+
+static void
+enlarge_hashmap_mem (hashmap *hm, hashmap_entry **data, bool f)
+{
+ shared_mem_ptr old_data_p;
+ size_t old_size;
+
+ old_data_p = hm->s->data;
+ old_size = hm->s->size;
+
+ hm->s->data = allocator_shared_malloc (hm->a, (hm->s->size *= 2)
+ * sizeof (hashmap_entry));
+ hm->s->bitnum++;
+
+ *data = get_data (hm);
+ for (size_t i = 0; i < hm->s->size; i++)
+ (*data)[i] = ((hashmap_entry){
+ .id = 0, .p = SHMPTR_NULL, .s = 0, .max_lookahead = 0, .refcnt = 0 });
+
+ if (f)
+ allocator_shared_free (hm->a, old_data_p, old_size);
+}
+
+/* Resize hashmap. */
+
+static void
+resize_hm (hashmap *hm, hashmap_entry **data)
+{
+ shared_mem_ptr old_data_p;
+ hashmap_entry *old_data, *new_data;
+ size_t old_size;
+ ssize_t new_offset, inital_index, new_index;
+ memid id;
+ ssize_t max_lookahead;
+
+ /* old_data points to the old block containing the hashmap. We
+ redistribute the data from there into the new block. */
+
+ old_data_p = hm->s->data;
+ old_data = *data;
+ old_size = hm->s->size;
+
+ enlarge_hashmap_mem (hm, &new_data, false);
+retry_resize:
+ for (size_t i = 0; i < old_size; i++)
+ {
+ if (SHMPTR_IS_NULL (old_data[i].p))
+ continue;
+
+ id = old_data[i].id;
+ inital_index = get_expected_offset (hm, id);
+ new_offset = scan_empty (hm, inital_index);
+
+ /* If we didn't find a free slot, just resize the hashmap
+ again. */
+ if (new_offset == -1)
+ {
+ enlarge_hashmap_mem (hm, &new_data, true);
+ goto retry_resize; /* Sue me. */
+ }
+
+ new_index = hmiadd (hm, inital_index, new_offset);
+ max_lookahead = new_data[inital_index].max_lookahead;
+ new_data[inital_index].max_lookahead
+ = new_offset > max_lookahead ? new_offset : max_lookahead;
+
+ new_data[new_index] = ((hashmap_entry){
+ .id = id,
+ .p = old_data[i].p,
+ .s = old_data[i].s,
+ .max_lookahead = new_data[new_index].max_lookahead,
+ .refcnt = old_data[i].refcnt });
+ }
+ allocator_shared_free (hm->a, old_data_p, old_size);
+ *data = new_data;
+}
+
+/* Set an entry in the hashmap. */
+
+void
+hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,
+ shared_mem_ptr p, size_t size)
+{
+ hashmap_entry *data;
+ ssize_t expected_offset, lookahead;
+ ssize_t empty_offset;
+ ssize_t delta;
+
+ data = get_data (hm);
+
+ if (hsr)
+ {
+ data[hsr->res_offset].s = size;
+ data[hsr->res_offset].p = p;
+ return;
+ }
+
+ expected_offset = get_expected_offset (hm, id);
+ while ((delta = scan_empty (hm, expected_offset)) == -1)
+ {
+ resize_hm (hm, &data);
+ expected_offset = get_expected_offset (hm, id);
+ }
+
+ empty_offset = hmiadd (hm, expected_offset, delta);
+ lookahead = data[expected_offset].max_lookahead;
+ data[expected_offset].max_lookahead = delta > lookahead ? delta : lookahead;
+ data[empty_offset]
+ = ((hashmap_entry){ .id = id,
+ .p = p,
+ .s = size,
+ .max_lookahead = data[empty_offset].max_lookahead,
+ .refcnt = 1 });
+
+ n_ent++;
+ /* TODO: Shouldn't reset refcnt, but this doesn't matter at the
+ moment because of the way the function is used. */
+}
+
+/* Change the refcount of a hashmap entry. */
+
+static int
+hashmap_change_refcnt (hashmap *hm, memid id, hashmap_search_result *res,
+ int delta)
+{
+ hashmap_entry *data;
+ hashmap_search_result r;
+ hashmap_search_result *pr;
+ int ret;
+ hashmap_entry *entry;
+
+ data = get_data (hm);
+
+ if (res)
+ pr = res;
+ else
+ {
+ r = hashmap_get (hm, id);
+ pr = &r;
+ }
+
+ entry = &data[pr->res_offset];
+ ret = (entry->refcnt += delta);
+ if (ret == 0)
+ {
+ n_ent--;
+ entry->id = 0;
+ entry->p = SHMPTR_NULL;
+ entry->s = 0;
+ }
+
+ return ret;
+}
+
+/* Increase hashmap entry refcount. */
+
+void
+hashmap_inc (hashmap *hm, memid id, hashmap_search_result *res)
+{
+ hashmap_change_refcnt (hm, id, res, 1);
+}
+
+/* Decrease hashmap entry refcount. */
+
+int
+hashmap_dec (hashmap *hm, memid id, hashmap_search_result *res)
+{
+ return hashmap_change_refcnt (hm, id, res, -1);
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef HASHMAP_H
+#define HASHMAP_H
+
+#include "allocator.h"
+
+#include <stdbool.h>
+#include <stddef.h>
+#include <stdint.h>
+
+/* Data structures and variables:
+
+ memid is a unique identifier for the coarray. */
+
+typedef uint64_t memid;
+
+typedef struct {
+ shared_mem_ptr data;
+ size_t size;
+ int bitnum;
+} hashmap_shared;
+
+typedef struct hashmap
+{
+ hashmap_shared *s;
+ shared_memory sm;
+ allocator *a;
+} hashmap;
+
+typedef struct {
+ shared_mem_ptr p;
+ size_t size;
+ ssize_t res_offset;
+} hashmap_search_result;
+
+/* Initialize the hashmap on a worker image. */
+
+void hashmap_init (hashmap *, hashmap_shared *, allocator *a);
+
+/* Initialize the hashmap on the supervisor. This routine must be called only
+ on the supervisor. */
+
+void hashmap_init_supervisor (hashmap *, hashmap_shared *, allocator *);
+
+/* Look up memid in the hashmap. The result can be inspected via the
+ hm_search_result_* functions. */
+
+hashmap_search_result hashmap_get (hashmap *, memid);
+
+/* Given a search result, returns the size. */
+size_t hm_search_result_size (hashmap_search_result *);
+
+/* Given a search result, returns the pointer. */
+shared_mem_ptr hm_search_result_ptr (hashmap_search_result *);
+
+/* Given a search result, returns whether something was found. */
+bool hm_search_result_contains (hashmap_search_result *);
+
+/* Sets the hashmap entry for memid to shared_mem_ptr and
+ size_t. Optionally, if a hashmap_search_result is supplied, it is
+ used to make the lookup faster. */
+
+void hashmap_set (hashmap *, memid, hashmap_search_result *, shared_mem_ptr p,
+ size_t);
+
+/* Increments the hashmap entry for memid. Optionally, if a
+ hashmap_search_result is supplied, it is used to make the lookup
+ faster. */
+
+void hashmap_inc (hashmap *, memid, hashmap_search_result *);
+
+/* Same, but decrement. */
+int hashmap_dec (hashmap *, memid, hashmap_search_result *);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "libgfortran.h"
+#include "allocator.h"
+#include "shared_memory.h"
+
+#include <assert.h>
+#include <fcntl.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/mman.h>
+#include <unistd.h>
+
+/* This implements shared memory based on POSIX mmap. We start with
+ memory block of the size of the global shared memory data, rounded
+ up to one pagesize, and enlarge as needed.
+
+ We address the memory via a shared_memory_ptr, which is an offset into
+ the shared memory block. The metadata is situated at offset 0.
+
+ In order to be able to resize the memory and to keep pointers
+ valid, we keep the old mapping around, so the memory is actually
+ visible several times to the process. Thus, pointers returned by
+ shared_memory_get_mem_with_alignment remain valid even when
+ resizing. */
+
+static const char *ENV_PPID = "GFORTRAN_SHMEM_PPID";
+static const char *ENV_BASE = "GFORTRAN_SHMEM_BASE";
+
+void
+shared_memory_set_env (pid_t pid)
+{
+#define bufsize 20
+ char buffer[bufsize];
+
+ snprintf (buffer, bufsize, "%d", pid);
+ setenv (ENV_PPID, buffer, 1);
+#undef bufsize
+}
+
+char *
+shared_memory_get_env (void)
+{
+ return getenv (ENV_PPID);
+}
+
+/* Get a pointer into the shared memory block with alignemnt
+ (works similar to sbrk). */
+
+shared_mem_ptr
+shared_memory_get_mem_with_alignment (shared_memory_act *mem, size_t size,
+ size_t align)
+{
+ size_t aligned_curr_size = alignto (mem->glbl.meta->used, align);
+ mem->glbl.meta->used = aligned_curr_size + size;
+ return (shared_mem_ptr) {aligned_curr_size};
+}
+
+shared_mem_ptr
+shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align)
+{
+ if (mem->glbl.meta->master)
+ return (shared_mem_ptr) {mem->glbl.meta->master};
+ else
+ {
+ ptrdiff_t loc = mem->glbl.meta->used;
+ shared_mem_ptr p
+ = shared_memory_get_mem_with_alignment (mem, size, align);
+ mem->glbl.meta->master = loc;
+ return p;
+ }
+}
+
+/* If another image changed the size, update the size accordingly. */
+
+void
+shared_memory_prepare (shared_memory_act *)
+{
+ asm volatile ("" ::: "memory");
+}
+
+#define NAME_MAX 255
+
+/* Initialize the memory with one page, the shared metadata of the
+ shared memory is stored at the beginning. */
+
+void
+shared_memory_init (shared_memory_act *mem, size_t size)
+{
+ char shm_name[NAME_MAX];
+ const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE);
+ pid_t ppid = getpid ();
+ int shm_fd, res;
+ void *base_ptr;
+
+ if (env_val)
+ {
+ int n = sscanf (env_val, "%d", &ppid);
+ assert (n == 1);
+ }
+ snprintf (shm_name, NAME_MAX, "/gfor-shm-%d", ppid);
+ if (base)
+ {
+ int n = sscanf (base, "%p", &base_ptr);
+ assert (n == 1);
+ }
+ else
+ base_ptr = NULL;
+
+ if (!env_val)
+ {
+ shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
+ if (shm_fd == -1)
+ {
+ perror ("creating shared memory segment failed.");
+ exit (1);
+ }
+
+ res = ftruncate (shm_fd, size);
+ if (res == -1)
+ {
+ perror ("resizing shared memory segment failed.");
+ exit (1);
+ }
+ }
+ else
+ {
+ shm_fd = shm_open (shm_name, O_RDWR, 0);
+ if (shm_fd == -1)
+ {
+ perror ("opening shared memory segment failed.");
+ exit (1);
+ }
+ }
+
+ mem->glbl.base
+ = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, shm_fd, 0);
+ res = close (shm_fd);
+ if (mem->glbl.base == MAP_FAILED)
+ {
+ perror ("mmap failed");
+ exit (1);
+ }
+ if (!base_ptr)
+ {
+#define bufsize 20
+ char buffer[bufsize];
+
+ snprintf (buffer, bufsize, "%p", mem->glbl.base);
+ setenv (ENV_BASE, buffer, 1);
+#undef bufsize
+ }
+ if (res)
+ { // from close()
+ perror ("closing shm file handle failed. Trying to continue...");
+ }
+ mem->size = size;
+ if (!env_val)
+ *mem->glbl.meta
+ = (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0};
+
+}
+
+void
+shared_memory_cleanup (shared_memory_act *)
+{
+ char shm_name[NAME_MAX];
+ int res;
+
+ snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
+ res = shm_unlink (shm_name);
+ if (res == -1)
+ {
+ perror ("shm_unlink failed");
+ exit (1);
+ }
+}
+#undef NAME_MAX
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef SHARED_MEMORY_H
+#define SHARED_MEMORY_H
+
+#include <stdlib.h>
+#include <stddef.h>
+#include <unistd.h>
+
+/* Global metadata for shared memory, always kept at offset 0. */
+
+typedef struct
+{
+ size_t used;
+ ptrdiff_t master;
+} global_shared_memory_meta;
+
+/* Type realization for shared_memory. */
+
+typedef struct shared_memory_act
+{
+ union
+ {
+ void *base;
+ global_shared_memory_meta *meta;
+ } glbl;
+ size_t size; // const
+} shared_memory_act;
+
+/* A struct to serve as shared memory object. */
+
+typedef struct shared_memory_act * shared_memory;
+
+#define SHMPTR_NULL ((shared_mem_ptr) {.offset = 0})
+#define SHMPTR_IS_NULL(x) (x.offset == 0)
+
+#define SHMPTR_DEREF(x, s, sm) ((x) = *(__typeof (x) *) s.p)
+#define SHMPTR_AS(type, s, sm) ((type) (*((void **) sm) + s.offset))
+#define AS_SHMPTR(p, sm) ((shared_mem_ptr) {.offset = (p) - sm.glbl.base})
+
+#define SHARED_MEMORY_RAW_ALLOC(mem, t, n) \
+ shared_memory_get_mem_with_alignment (mem, sizeof (t) * n, __alignof__ (t))
+
+#define SHARED_MEMORY_RAW_ALLOC_PTR(mem, t) \
+ SHMPTR_AS (t *, SHARED_MEMORY_RAW_ALLOC (mem, t, 1), mem)
+
+/* A shared-memory pointer is implemented as an offset into the shared
+ memory region. */
+
+typedef struct shared_mem_ptr
+{
+ ptrdiff_t offset;
+} shared_mem_ptr;
+
+void shared_memory_init (shared_memory, size_t);
+
+void shared_memory_cleanup (shared_memory);
+
+void shared_memory_prepare (shared_memory);
+
+shared_mem_ptr shared_memory_get_mem_with_alignment (shared_memory mem,
+ size_t size, size_t align);
+
+shared_mem_ptr shared_memory_get_master (shared_memory pmem, size_t size,
+ size_t align);
+
+void shared_memory_set_env (pid_t pid);
+
+char *shared_memory_get_env (void);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "config.h"
+
+#include "../caf_error.h"
+#include "supervisor.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <assert.h>
+#include <signal.h>
+#include <string.h>
+#include <unistd.h>
+#ifdef HAVE_WAIT_H
+#include <wait.h>
+#elif HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+#define GFORTRAN_ENV_NUM_IMAGES "GFORTRAN_NUM_IMAGES"
+#define GFORTRAN_ENV_SHARED_MEMORY_SIZE "GFORTRAN_SHARED_MEMORY_SIZE"
+#define GFORTRAN_ENV_IMAGE_NUM "GFORTRAN_IMAGE_NUM"
+
+image_local *local = NULL;
+
+image this_image = {-1, NULL};
+
+/* Get image number from environment or sysconf. */
+
+static int
+get_image_num_from_envvar (void)
+{
+ char *num_images_char;
+ int nimages;
+ num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES);
+ if (!num_images_char)
+ return sysconf (_SC_NPROCESSORS_ONLN); /* TODO: Make portable. */
+ /* TODO: Error checking. */
+ nimages = atoi (num_images_char);
+ return nimages;
+}
+
+/* Get the amount of memory for the shared memory block. This is picked from
+ an environment variable. If that is not there, pick a reasonable default.
+ Note that on a 64-bit system which allows overcommit, there is no penalty in
+ reserving a large space and then not using it. */
+
+static size_t
+get_memory_size_from_envvar (void)
+{
+ char *e;
+ size_t sz = 0;
+ e = getenv (GFORTRAN_ENV_SHARED_MEMORY_SIZE);
+ if (e)
+ {
+ char suffix[2];
+ int rv;
+ rv = sscanf (e, "%zu%1s", &sz, suffix);
+ if (rv == 2)
+ {
+ switch (suffix[0])
+ {
+ case 'k':
+ case 'K':
+ sz *= ((size_t) 1) << 10;
+ break;
+ case 'm':
+ case 'M':
+ sz *= ((size_t) 1) << 20;
+ break;
+ case 'g':
+ case 'G':
+ sz *= ((size_t) 1) << 30;
+ break;
+ default:
+ sz = 0;
+ }
+ }
+ }
+ if (sz == 0)
+ {
+ /* Use 256 MB for 32-bit systems and 4 GB for 64-bit systems. */
+ if (sizeof (size_t) == 4)
+ sz = ((size_t) 1) << 28;
+ else
+ sz = ((size_t) 1) << 34;
+ }
+ return sz;
+}
+
+/* Get a supervisor. */
+
+static supervisor *
+get_supervisor (void)
+{
+ supervisor *sv;
+ sv = SHMPTR_AS (supervisor *,
+ shared_memory_get_master (&local->sm,
+ sizeof (supervisor)
+ + sizeof (image_tracker)
+ * local->total_num_images,
+ __alignof__ (supervisor)),
+ &local->sm);
+ sv->failed_images = 0;
+ sv->finished_images = 0;
+ return sv;
+}
+
+/* Defined in shmem.c, but we need it here. */
+
+extern memid next_memid;
+
+#define SUPERVISOR_MAGIC_NUM 0x12345678
+
+/* Ensure things are initialized. */
+
+void
+ensure_shmem_initialization (void)
+{
+ size_t shmem_size;
+ char *image_num;
+
+ if (local)
+ return;
+
+ local = malloc (sizeof (image_local));
+ pagesize = sysconf (_SC_PAGE_SIZE);
+ shmem_size = round_to_pagesize (get_memory_size_from_envvar ());
+ local->total_num_images = get_image_num_from_envvar ();
+ shared_memory_init (&local->sm, shmem_size);
+ shared_memory_prepare (&local->sm);
+
+ /* Shared memory needs to be present, before master can be initialized/linked
+ to. */
+ image_num = getenv (GFORTRAN_ENV_IMAGE_NUM);
+ if (image_num)
+ {
+ bool created;
+ this_image = (image) {atoi (image_num), get_supervisor ()};
+ assert (this_image.supervisor->magic_number == SUPERVISOR_MAGIC_NUM);
+
+ alloc_init (&local->ai, &local->sm);
+
+ caf_initial_team = caf_current_team
+ = (caf_shmem_team_t) calloc (1, sizeof (struct caf_shmem_team));
+ allocator_lock (&local->ai.alloc);
+ *caf_initial_team = (struct caf_shmem_team) {
+ NULL,
+ -1,
+ this_image.image_num,
+ 0,
+ NULL,
+ {alloc_get_memory_by_id_created (&local->ai,
+ local->total_num_images * sizeof (int)
+ + sizeof (struct shmem_image_info),
+ next_memid++, &created)}};
+ if (created)
+ {
+ counter_barrier_init (&caf_initial_team->u.image_info->image_count,
+ local->total_num_images);
+ collsub_init_supervisor (&caf_initial_team->u.image_info->collsub,
+ alloc_get_allocator (&local->ai),
+ local->total_num_images);
+ 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
+ = local->total_num_images;
+ caf_initial_team->u.image_info->num_term_images = 0;
+ 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;
+ }
+ allocator_unlock (&local->ai.alloc);
+ sync_init (&local->si, &local->sm);
+ }
+ else
+ {
+ this_image = (image) {-1, get_supervisor ()};
+ this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM;
+ counter_barrier_init (&this_image.supervisor->num_active_images,
+ local->total_num_images);
+ alloc_init_supervisor (&local->ai, &local->sm);
+ sync_init_supervisor (&local->si, &local->ai);
+ }
+}
+
+extern char **environ;
+
+int
+supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,
+ int *exit_code)
+{
+ supervisor *m;
+ pid_t new_pid, finished_pid;
+ image im;
+ int chstatus;
+
+ *exit_code = 0;
+ shared_memory_set_env (getpid ());
+ m = this_image.supervisor;
+
+ for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
+ {
+ if ((new_pid = fork ()))
+ {
+ if (new_pid == -1)
+ caf_runtime_error ("error spawning child\n");
+ m->images[im.image_num] = (image_tracker) {new_pid, IMAGE_OK};
+ }
+ else
+ {
+ static char **new_env;
+ static char num_image[32];
+ size_t n = 2; /* Add one env-var and one for the term NULL. */
+
+ /* Count the number of entries in the current environment. */
+ for (char **e = environ; *e; ++e, ++n)
+ ;
+ new_env = (char **) malloc (sizeof (char *) * n);
+ memcpy (new_env, environ, sizeof (char *) * (n - 2));
+ snprintf (num_image, 32, "%s=%d", GFORTRAN_ENV_IMAGE_NUM,
+ im.image_num);
+ new_env[n - 2] = num_image;
+ new_env[n - 1] = NULL;
+ execve ((*argv)[0], *argv, new_env);
+ return 1;
+ }
+ }
+ for (int j, i = 0; i < local->total_num_images; i++)
+ {
+ finished_pid = wait (&chstatus);
+ if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))
+ {
+ for (j = 0;
+ j < local->total_num_images && m->images[j].pid != finished_pid;
+ j++)
+ ;
+ /* Only set the status, when it has not been set by the (failing)
+ image already. */
+ if (m->images[j].status == IMAGE_OK)
+ {
+ m->images[j].status = IMAGE_SUCCESS;
+ atomic_fetch_add (&m->finished_images, 1);
+ }
+ }
+ else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus))
+ {
+ for (j = 0;
+ j < local->total_num_images && m->images[j].pid != finished_pid;
+ j++)
+ ;
+ dprintf (2, "ERROR: Image %d(pid: %d) failed with %d.\n", j + 1,
+ finished_pid, WTERMSIG (chstatus));
+ if (j == local->total_num_images)
+ {
+ if (finished_pid == getpid ())
+ {
+ dprintf (2,
+ "WARNING: Supervisor process got signal %d. Killing "
+ "childs and exiting.\n",
+ WTERMSIG (chstatus));
+ for (j = 0; j < local->total_num_images; j++)
+ {
+ if (m->images[j].status == IMAGE_OK)
+ kill (m->images[j].pid, SIGKILL);
+ }
+ exit (1);
+ }
+ dprintf (2,
+ "WARNING: Got signal %d for unknown process %d. "
+ "Ignoring and trying to continue.\n",
+ WTERMSIG (chstatus), finished_pid);
+ continue;
+ }
+ m->images[j].status = IMAGE_FAILED;
+ atomic_fetch_add (&m->failed_images, 1);
+ if (*exit_code < WTERMSIG (chstatus))
+ *exit_code = WTERMSIG (chstatus);
+ else if (*exit_code == 0)
+ *exit_code = 1;
+ }
+ /* Trigger waiting sync images aka sync_table. */
+ for (j = 0; j < local->total_num_images; j++)
+ pthread_cond_signal (&SHMPTR_AS (pthread_cond_t *,
+ m->sync_shared.sync_images_cond_vars,
+ &local->sm)[j]);
+ counter_barrier_add (&m->num_active_images, -1);
+ }
+ return 0;
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef SUPERVISOR_H
+#define SUPERVISOR_H
+
+#include "caf/libcaf.h"
+#include "alloc.h"
+#include "collective_subroutine.h"
+#include "sync.h"
+
+#include <stdatomic.h>
+
+typedef enum
+{
+ IMAGE_UNKNOWN = 0,
+ IMAGE_OK,
+ IMAGE_FAILED,
+ IMAGE_SUCCESS
+} image_status;
+
+typedef struct
+{
+ pid_t pid;
+ image_status status;
+} image_tracker;
+
+typedef struct supervisor
+{
+ ptrdiff_t magic_number;
+ alloc_shared alloc_shared;
+ hashmap_shared hms;
+ collsub_shared collsub_shared;
+ sync_shared sync_shared;
+ atomic_int failed_images;
+ atomic_int finished_images;
+ counter_barrier num_active_images;
+ pthread_mutex_t image_tracker_lock;
+ image_tracker images[];
+} supervisor;
+
+typedef struct
+{
+ int image_num;
+ supervisor *supervisor;
+} image;
+
+extern image this_image;
+
+typedef struct
+{
+ int total_num_images;
+ struct shared_memory_act sm;
+ alloc ai;
+ sync_t si;
+} image_local;
+
+extern image_local *local;
+
+struct caf_shmem_token
+{
+ /* The pointer to the memory registered for the current image. For arrays
+ this is the data member in the descriptor. For components it's the pure
+ data pointer. */
+ void *memptr;
+ /* The descriptor when this token is associated to an allocatable array. */
+ gfc_descriptor_t *desc;
+ /* The base address this coarray's memory in the shared memory space. The
+ base address of image I is computed by base + I * image_size. */
+ void *base;
+ /* The size of memory in each image aligned on pointer borders, i.e. each
+ images memory starts on an address that is aligned to enable maximum speed
+ for the processor architecure used. */
+ size_t image_size;
+ /* The id of this token. */
+ memid token_id;
+ /* Set when the caf lib has allocated the memory in memptr and is responsible
+ for freeing it on deregister. */
+ bool owning_memory;
+};
+typedef struct caf_shmem_token *caf_shmem_token_t;
+
+
+/* Ensure the shared memory environment is up and all support structures are
+ initialized and linked correctly. */
+
+void ensure_shmem_initialization (void);
+
+int supervisor_main_loop (int *argc, char ***argv, int *exit_code);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "libgfortran.h"
+#include "supervisor.h"
+#include "sync.h"
+#include "teams_mgmt.h"
+#include "thread_support.h"
+
+#include <string.h>
+
+static inline void
+lock_table (sync_t *si)
+{
+ pthread_mutex_lock (&si->cis->sync_images_table_lock);
+}
+
+static inline void
+unlock_table (sync_t *si)
+{
+ pthread_mutex_unlock (&si->cis->sync_images_table_lock);
+}
+
+void
+sync_init (sync_t *si, shared_memory sm)
+{
+ *si = (sync_t) {
+ &this_image.supervisor->sync_shared,
+ SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm),
+ SHMPTR_AS (pthread_cond_t *,
+ this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};
+}
+
+void
+sync_init_supervisor (sync_t *si, alloc *ai)
+{
+ const int num_images = local->total_num_images;
+ const size_t table_size_in_bytes = sizeof (int) * num_images * num_images;
+
+ si->cis = &this_image.supervisor->sync_shared;
+
+ initialize_shared_mutex (&si->cis->event_lock);
+ initialize_shared_condition (&si->cis->event_cond);
+
+ initialize_shared_mutex (&si->cis->sync_images_table_lock);
+
+ si->cis->sync_images_table
+ = allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes);
+ si->cis->sync_images_cond_vars
+ = allocator_shared_malloc (alloc_get_allocator (ai),
+ sizeof (pthread_cond_t) * num_images);
+
+ si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
+ si->triggers
+ = SHMPTR_AS (pthread_cond_t *, si->cis->sync_images_cond_vars, ai->mem);
+
+ for (int i = 0; i < num_images; i++)
+ initialize_shared_condition (&si->triggers[i]);
+
+ memset (si->table, 0, table_size_in_bytes);
+}
+
+void
+sync_table (sync_t *si, int *images, int size)
+{
+ /* The variable `table` is an N x N matrix, where N is the number of all
+ images. The position (i, j) (where i and j are always the real images
+ index, i.e. after team de-mapping) tells whether image i has seen the same
+ number of synchronisation calls to sync_table like j. When table(i,j) ==
+ table(j,i) then the sync for i with this image is completed (here j is the
+ real image index of the current image). When this holds for all i in the
+ current set of images (or all images, if the set is empty), then sync table
+ command is completed.
+ */
+ volatile int *table = si->table;
+ int i;
+
+ lock_table (si);
+ if (size > 0)
+ {
+ const size_t img_c = caf_current_team->u.image_info->image_map_size;
+ for (i = 0; i < size; ++i)
+ {
+ ++table[images[i] + img_c * this_image.image_num];
+ pthread_cond_signal (&si->triggers[images[i]]);
+ }
+ for (;;)
+ {
+ for (i = 0; i < size; ++i)
+ if (this_image.supervisor->images[images[i]].status == IMAGE_OK
+ && table[images[i] + this_image.image_num * img_c]
+ > table[this_image.image_num + images[i] * img_c])
+ break;
+ if (i == size)
+ break;
+ pthread_cond_wait (&si->triggers[this_image.image_num],
+ &si->cis->sync_images_table_lock);
+ }
+ }
+ else
+ {
+ int *map = caf_current_team->u.image_info->image_map;
+ size = caf_current_team->u.image_info->image_count.count;
+ for (i = 0; i < size; ++i)
+ {
+ if (this_image.supervisor->images[map[i]].status != IMAGE_OK)
+ continue;
+ ++table[map[i] + size * this_image.image_num];
+ pthread_cond_signal (&si->triggers[map[i]]);
+ }
+ for (;;)
+ {
+ for (i = 0; i < size; ++i)
+ if (this_image.supervisor->images[map[i]].status == IMAGE_OK
+ && table[map[i] + size * this_image.image_num]
+ > table[this_image.image_num + map[i] * size])
+ break;
+ if (i == size)
+ break;
+ pthread_cond_wait (&si->triggers[this_image.image_num],
+ &si->cis->sync_images_table_lock);
+ }
+ }
+ unlock_table (si);
+}
+
+void
+sync_all (void)
+{
+ counter_barrier_wait (&caf_current_team->u.image_info->image_count);
+}
+
+void
+sync_team (caf_shmem_team_t team)
+{
+ counter_barrier_wait (&team->u.image_info->image_count);
+}
+
+void
+lock_event (sync_t *si)
+{
+ pthread_mutex_lock (&si->cis->event_lock);
+}
+
+void
+unlock_event (sync_t *si)
+{
+ pthread_mutex_unlock (&si->cis->event_lock);
+}
+
+void
+event_post (sync_t *si)
+{
+ pthread_cond_broadcast (&si->cis->event_cond);
+}
+
+void
+event_wait (sync_t *si)
+{
+ pthread_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef SYNC_H
+#define SYNC_H
+
+#include "alloc.h"
+#include "counter_barrier.h"
+
+#include <pthread.h>
+
+typedef struct {
+ /* Mutex and condition variable needed for signaling events. */
+ pthread_mutex_t event_lock;
+ pthread_cond_t event_cond;
+ pthread_mutex_t sync_images_table_lock;
+ shared_mem_ptr sync_images_table;
+ shared_mem_ptr sync_images_cond_vars;
+} sync_shared;
+
+typedef struct {
+ sync_shared *cis;
+ int *table; // we can cache the table and the trigger pointers here
+ pthread_cond_t *triggers;
+} sync_t;
+
+typedef pthread_mutex_t lock_t;
+
+typedef int event_t;
+
+void sync_init (sync_t *, shared_memory);
+
+void sync_init_supervisor (sync_t *, alloc *);
+
+void sync_all (void);
+
+/* Prototype for circular dependency break. */
+
+struct caf_shmem_team;
+typedef struct caf_shmem_team *caf_shmem_team_t;
+
+void sync_team (caf_shmem_team_t team);
+
+void sync_table (sync_t *, int *, int);
+
+void lock_alloc_lock (sync_t *);
+
+void unlock_alloc_lock (sync_t *);
+
+void lock_event (sync_t *);
+
+void unlock_event (sync_t *);
+
+void event_post (sync_t *);
+
+void event_wait (sync_t *);
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "teams_mgmt.h"
+#include "../caf_error.h"
+
+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)
+{
+ pthread_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;
+
+ counter_barrier_add_locked (&team->u.image_info->image_count,
+ old_num
+ - team->u.image_info->num_term_images);
+ }
+ pthread_mutex_unlock (&team->u.image_info->image_count.mutex);
+}
+
+void
+check_health (int *stat, char *errmsg, size_t errmsg_len)
+{
+ if (this_image.supervisor->finished_images
+ || this_image.supervisor->failed_images)
+ {
+ 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;
+ }
+ }
+ else if (stat)
+ *stat = 0;
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef TEAMS_MGMT_H
+#define TEAMS_MGMT_H
+
+#include "alloc.h"
+#include "collective_subroutine.h"
+#include "supervisor.h"
+
+struct caf_shmem_team
+{
+ struct caf_shmem_team *parent;
+ int team_no;
+ /* The index is the image's index minus one in this team. I.e. if in Fortran
+ notion the current image is 3, then the value of index is 2. This allows
+ access to the image_map without having to substract one each time (and
+ missing it). Returning the image's index to the user is rarer, so adding
+ one there is cheaper. */
+ int index;
+ /* The last memid the parent team used. This is used to restore the memid
+ on an end team. */
+ memid parent_teams_last_active_memid;
+ struct coarray_allocated
+ {
+ struct coarray_allocated *next;
+ caf_shmem_token_t token;
+ } *allocated;
+ union
+ {
+ void *shm;
+ struct shmem_image_info
+ {
+ counter_barrier image_count;
+ struct collsub_shared collsub;
+ int team_parent_id;
+ int team_id;
+ int image_map_size;
+ /* Store the last known number of terminated images (either stopped or
+ failed) images. On each access where all images need to be present
+ this is checked against the global number and the image_count and
+ image_map is updated. */
+ int num_term_images;
+ memid lastmemid;
+ int image_map[];
+ } *image_info;
+ } u;
+};
+typedef struct caf_shmem_team *caf_shmem_team_t;
+
+/* The team currently active. */
+extern caf_shmem_team_t caf_current_team;
+
+/* The initial team. */
+extern caf_shmem_team_t caf_initial_team;
+
+/* Teams formed, but not in used currently. */
+extern caf_shmem_team_t caf_teams_formed;
+
+#define CHECK_TEAM_INTEGRITY(team) \
+ if (unlikely (team->u.image_info->num_term_images \
+ != this_image.supervisor->failed_images \
+ + this_image.supervisor->finished_images)) \
+ update_teams_images (team)
+
+void update_teams_images (caf_shmem_team_t);
+
+void check_health (int *, char *, size_t);
+
+#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)
+
+#endif
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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 "thread_support.h"
+
+#include <errno.h>
+#include <stdlib.h>
+#include <stdio.h>
+
+#define ERRCHECK(a) \
+ do \
+ { \
+ int rc = a; \
+ if (rc) \
+ { \
+ errno = rc; \
+ perror (#a " failed"); \
+ exit (1); \
+ } \
+ } \
+ while (0)
+
+void
+initialize_shared_mutex (pthread_mutex_t *mutex)
+{
+ pthread_mutexattr_t mattr;
+ ERRCHECK (pthread_mutexattr_init (&mattr));
+ ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
+ ERRCHECK (pthread_mutex_init (mutex, &mattr));
+ ERRCHECK (pthread_mutexattr_destroy (&mattr));
+}
+
+void
+initialize_shared_errorcheck_mutex (pthread_mutex_t *mutex)
+{
+ pthread_mutexattr_t mattr;
+ ERRCHECK (pthread_mutexattr_init (&mattr));
+ ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
+ ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));
+ ERRCHECK (pthread_mutex_init (mutex, &mattr));
+ ERRCHECK (pthread_mutexattr_destroy (&mattr));
+}
+
+void
+initialize_shared_condition (pthread_cond_t *cond)
+{
+ pthread_condattr_t cattr;
+ ERRCHECK (pthread_condattr_init (&cattr));
+ ERRCHECK (pthread_condattr_setpshared (&cattr, PTHREAD_PROCESS_SHARED));
+ ERRCHECK (pthread_cond_init (cond, &cattr));
+ ERRCHECK (pthread_condattr_destroy (&cattr));
+}
--- /dev/null
+/* Copyright (C) 2025 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild
+
+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).
+
+Caf_shmem is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3, or (at your option)
+any later version.
+
+Caf_shmem is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+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/>. */
+
+#ifndef THREAD_SUPPORT_H
+#define THREAD_SUPPORT_H
+
+#include <pthread.h>
+
+/* Support routines to setup pthread structs in shared memory. */
+
+void initialize_shared_mutex (pthread_mutex_t *);
+
+void initialize_shared_errorcheck_mutex (pthread_mutex_t *);
+
+void initialize_shared_condition (pthread_cond_t *);
+
+#endif
projects / thirdparty / gcc.git / commitdiff
