Testing only. Work in progress.
gcc/fortran/ChangeLog:
* check.cc (gfc_check_image_status): Modify
(gfc_check_failed_or_stopped_images): Modify
* coarray.cc (check_add_new_component): Modify
* invoke.texi: Modify
* trans-decl.cc (gfc_build_builtin_function_decls): Modify
* trans-expr.cc (get_scalar_to_descriptor_type): Modify
(copy_coarray_desc_part): Modify
(gfc_class_array_data_assign): Modify
(gfc_conv_derived_to_class): Modify
* trans-intrinsic.cc (conv_intrinsic_image_status): Modify
* trans-stmt.cc (gfc_trans_sync): Modify
libgfortran/ChangeLog:
* Makefile.am: Modify
* Makefile.in: Modify
* caf/libcaf.h (LIBCAF_H): Modify
(_gfortran_caf_failed_images): Modify
(_gfortran_caf_image_status): Modify
(_gfortran_caf_stopped_images): Modify
* caf/single.c (caf_internal_error): Modify
* caf/caf_error.c: New file. Modify
* caf/caf_error.h: New file. Modify
* caf/shmem.c: New file.
* caf/shmem/alloc.c: New file.
* caf/shmem/alloc.h: New file.
* caf/shmem/allocator.c: New file.
* caf/shmem/allocator.h: New file.
* caf/shmem/collective_subroutine.c: New file.
* caf/shmem/collective_subroutine.h: New file.
* caf/shmem/counter_barrier.c: New file.
* caf/shmem/counter_barrier.h: New file.
* caf/shmem/hashmap.c: New file.
* caf/shmem/hashmap.h: New file.
* caf/shmem/shared_memory.c: New file.
* caf/shmem/shared_memory.h: New file.
* caf/shmem/supervisor.c: New file.
* caf/shmem/supervisor.h: New file.
* caf/shmem/sync.c: New file.
* caf/shmem/sync.h: New file.
* caf/shmem/teams_mgmt.c: New file.
* caf/shmem/teams_mgmt.h: New file.
* caf/shmem/thread_support.c: New file.
* caf/shmem/thread_support.h: New file.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/alloc_comp_4.f90: Modify
* gfortran.dg/coarray/atomic_2.f90: Modify
* gfortran.dg/coarray/caf.exp: Modify
* gfortran.dg/coarray/coarray_allocated.f90: Modify
* gfortran.dg/coarray/coindexed_1.f90: Modify
* gfortran.dg/coarray/coindexed_3.f08: Modify
* gfortran.dg/coarray/coindexed_5.f90: Modify
* gfortran.dg/coarray/dummy_3.f90: Modify
* gfortran.dg/coarray/event_1.f90: Modify
* gfortran.dg/coarray/event_3.f08: Modify
* gfortran.dg/coarray/event_4.f08: Modify
* gfortran.dg/coarray/failed_images_1.f08: Modify
* gfortran.dg/coarray/failed_images_2.f08: Modify
* gfortran.dg/coarray/image_status_1.f08: Modify
* gfortran.dg/coarray/image_status_2.f08: Modify
* gfortran.dg/coarray/lock_2.f90: Modify
* gfortran.dg/coarray/poly_run_3.f90: Modify
* gfortran.dg/coarray/scalar_alloc_1.f90: Modify
* gfortran.dg/coarray/stopped_images_1.f08: Modify
* gfortran.dg/coarray/stopped_images_2.f08: Modify
* gfortran.dg/coarray/sync_1.f90: Modify
* gfortran.dg/coarray/sync_3.f90: Modify
* gfortran.dg/coarray_sync_memory.f90: Modify
* gfortran.dg/coarray/co_reduce_string.f90: New test. Modify
* gfortran.dg/coarray/sync_team.f90: New test. Modify
|| !positive_check (0, image))
return false;
- return !team || (scalar_check (team, 0) && team_type_check (team, 0));
+ return !team || (scalar_check (team, 1) && team_type_check (team, 1));
}
bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{
- if (team)
- {
- gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
- gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
- &team->where);
- return false;
- }
+ if (team && (!scalar_check (team, 0) || !team_type_check (team, 0)))
+ return false;
if (kind)
{
check_add_new_component (type, actual->expr, add_data);
break;
case EXPR_FUNCTION:
- if (!e->symtree->n.sym->attr.pure
- && !e->symtree->n.sym->attr.elemental
- && !(e->value.function.isym
- && (e->value.function.isym->pure
- || e->value.function.isym->elemental)))
- /* Treat non-pure/non-elemental functions. */
- check_add_new_comp_handle_array (e, type, add_data);
+ if ((e->symtree->n.sym->attr.pure
+ && e->symtree->n.sym->attr.elemental)
+ || (e->value.function.isym && e->value.function.isym->pure
+ && e->value.function.isym->elemental))
+ {
+ /* Only allow pure and elemental function calls in a coarray
+ accessor, because all other may have side effects or access
+ pointers, which may not be possible in the accessor running on
+ another host. */
+ for (gfc_actual_arglist *actual = e->value.function.actual;
+ actual; actual = actual->next)
+ check_add_new_component (type, actual->expr, add_data);
+ }
else
- for (gfc_actual_arglist *actual = e->value.function.actual; actual;
- actual = actual->next)
- check_add_new_component (type, actual->expr, add_data);
+ /* Extract the expression, evaluate it and add a temporary with its
+ value to the helper structure. */
+ check_add_new_comp_handle_array (e, type, add_data);
break;
case EXPR_VARIABLE:
check_add_new_comp_handle_array (e, type, add_data);
* 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
get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node,
4, pvoid_type_node, pint_type, pchar_type_node, size_type_node);
- gfor_fndecl_caf_team_number
- = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_team_number")), ". r ",
- integer_type_node, 1, integer_type_node);
+ gfor_fndecl_caf_team_number = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_team_number")), ". r ", integer_type_node,
+ 1, pvoid_type_node);
gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX ("caf_image_status")), ". r r ",
get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
{
enum gfc_array_kind akind;
+ tree *lbound = NULL, *ubound = NULL;
+ int codim = 0;
if (attr.pointer)
akind = GFC_ARRAY_POINTER_CONT;
if (POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
+ if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
+ {
+ struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
+ codim = lang_specific->corank;
+ lbound = lang_specific->lbound;
+ ubound = lang_specific->ubound;
+ }
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
+ ubound, 1, akind,
+ !(attr.pointer || attr.target));
}
tree
return NULL_TREE;
}
+static void
+copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
+{
+ tree src_type = TREE_TYPE (src);
+ if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
+ {
+ struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
+ for (int c = 0; c < lang_specific->corank; ++c)
+ {
+ int dim = lang_specific->rank + c;
+ tree codim = gfc_rank_cst[dim];
+
+ if (lang_specific->lbound[dim])
+ gfc_conv_descriptor_lbound_set (block, dest, codim,
+ lang_specific->lbound[dim]);
+ else
+ gfc_conv_descriptor_lbound_set (
+ block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
+ if (dim + 1 < lang_specific->corank)
+ {
+ if (lang_specific->ubound[dim])
+ gfc_conv_descriptor_ubound_set (block, dest, codim,
+ lang_specific->ubound[dim]);
+ else
+ gfc_conv_descriptor_ubound_set (
+ block, dest, codim,
+ gfc_conv_descriptor_ubound_get (src, codim));
+ }
+ }
+ }
+}
+
void
gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
bool lhs_type)
{
- tree tmp, tmp2, type;
+ tree lhs_dim, rhs_dim, type;
gfc_conv_descriptor_data_set (block, lhs_desc,
gfc_conv_descriptor_data_get (rhs_desc));
gfc_conv_descriptor_dtype (rhs_desc));
/* Assign the dimension as range-ref. */
- tmp = gfc_get_descriptor_dimension (lhs_desc);
- tmp2 = gfc_get_descriptor_dimension (rhs_desc);
+ lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
+ rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
+
+ type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim);
+ lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+ gfc_add_modify (block, lhs_dim, rhs_dim);
- type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
- tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- gfc_add_modify (block, tmp, tmp2);
+ /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
+ copy_coarray_desc_part (block, lhs_desc, rhs_desc);
}
/* Takes a derived type expression and returns the address of a temporary
gfc_expr_attr (e));
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
gfc_get_dtype (type));
+ copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr);
if (optional)
parmse->expr = build3_loc (input_location, COND_EXPR,
TREE_TYPE (parmse->expr),
GFC_STAT_STOPPED_IMAGE));
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
+ /* The team is optional and therefore needs to be a pointer to the opaque
+ pointer. */
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
args[0],
- num_args < 2 ? null_pointer_node : args[1]);
+ num_args < 2
+ ? null_pointer_node
+ : gfc_build_addr_expr (NULL_TREE, args[1]));
else
gcc_unreachable ();
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
- images = argse.expr;
+ images = gfc_trans_force_lval (&argse.pre, argse.expr);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
}
if (code->expr2)
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr2);
stat = argse.expr;
+ gfc_add_block_to_block (&se.pre, &argse.pre);
}
else
stat = null_pointer_node;
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
- errmsg = gfc_build_addr_expr (NULL, argse.expr);
+ errmsg = argse.expr;
errmsglen = fold_convert (size_type_node, argse.string_length);
+ gfc_add_block_to_block (&se.pre, &argse.pre);
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
{
end type
type(mytype), save :: object[*]
- integer :: me
+ integer :: me, other
me=this_image()
- allocate(object%indices(me))
- object%indices = 42
+ other = me + 1
+ if (other .GT. num_images()) other = 1
+ if (me == num_images()) then
+ allocate(object%indices(me/2))
+ else
+ allocate(object%indices(me))
+ end if
+ object%indices = 42 * me
- if ( any( object[me]%indices(:) /= 42 ) ) STOP 1
+ sync all
+ if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1
+ sync all
end program
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12
+if (stat /= 0 .or. var /= num_images() * 2) STOP 12
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 13
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45
+if (stat /= 0 .or. var /= num_images() * 2) STOP 45
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 46
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
- if (stat /= 0 .or. var <= 0) STOP 53
+ if (stat /= 0) STOP 53
end do
end if
sync all
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
- if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68
+ if (stat /= 0) STOP 68
end do
end if
sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 82
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82
call atomic_ref(var2, caf_log[num_images()], stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 83
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83
end if
sync all
-if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84
+if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84
call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .true.) STOP 85
+if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85
sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 86
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86
call atomic_ref(var2, caf_log[num_images()], stat=stat)
- if (stat /= 0 .or. var2 .neqv. .false.) STOP 87
+ if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87
end if
sync all
-if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88
+if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88
call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .false.) STOP 89
+if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89
+sync all
end
}
}
+if { [getenv GFORTRAN_NUM_IMAGES] == "" } {
+ # Some caf_shmem tests need at least 8 images. This is also to limit the
+ # number of images on big machines preventing overload w/o any benefit.
+ setenv GFORTRAN_NUM_IMAGES 8
+}
+
# Main loop.
foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] {
# If we're only testing specific files and this isn't one of them, skip it.
dg-test $test "-fcoarray=lib $flags -lcaf_single" {}
cleanup-modules ""
}
+
+ foreach flags $option_list {
+ verbose "Testing $nshort (libcaf_shmem), $flags" 1
+ set gfortran_aux_module_flags "-fcoarray=lib $flags -lcaf_shmem"
+ dg-test $test "-fcoarray=lib $flags -lcaf_shmem" {}
+ cleanup-modules ""
+ }
}
torture-finish
dg-finish
--- /dev/null
+!{ dg-do run }
+
+! Check that co_reduce for strings works.
+! This test is motivated by OpenCoarray's co_reduce_string test.
+
+program co_reduce_strings
+
+ implicit none
+
+ integer, parameter :: numstrings = 10, strlen = 8, base_len = 4
+ character(len=strlen), dimension(numstrings) :: fixarr
+ character(len=strlen), dimension(:), allocatable :: allocarr
+ character(len=:), allocatable :: defarr(:)
+ character(len=strlen) :: expect
+ integer :: i
+
+ ! Construct the strings by postfixing foo by a number.
+ associate (me => this_image(), np => num_images())
+ if (np > 999) error stop "Too many images; increase format string modifiers and sizes!"
+
+ allocate(allocarr(numstrings))
+ do i = 1, numstrings
+ write(fixarr(i), "('foo',I04)") i * me
+ write(allocarr(i), "('foo',I04)") i * me
+ end do
+ ! Collectively reduce the maximum string.
+ call co_reduce(fixarr, fixmax)
+ call check(fixarr, 1)
+
+ call co_reduce(allocarr, strmax)
+ call check(allocarr, 2)
+ end associate
+
+ ! Construct the strings by postfixing foo by a number.
+ associate (me => this_image(), np => num_images())
+ allocate(character(len=base_len + 4)::defarr(numstrings))
+ do i = 1, numstrings
+ write(defarr(i), "('foo',I04)") i * me
+ end do
+ call sub_red(defarr)
+ end associate
+ sync all
+
+contains
+
+ pure function fixmax(lhs, rhs) result(m)
+ character(len=strlen), intent(in) :: lhs, rhs
+ character(len=strlen) :: m
+
+ if (lhs > rhs) then
+ m = lhs
+ else
+ m = rhs
+ end if
+ end function
+
+ pure function strmax(lhs, rhs) result(maxstr)
+ character(len=strlen), intent(in) :: lhs, rhs
+ character(len=strlen) :: maxstr
+
+ if (lhs > rhs) then
+ maxstr = lhs
+ else
+ maxstr = rhs
+ end if
+ end function
+
+ subroutine sub_red(str)
+ character(len=:), allocatable :: str(:)
+
+ call co_reduce(str, strmax)
+ call check(str, 3)
+ end subroutine
+
+ subroutine check(curr, stop_code)
+ character(len=*), intent(in) :: curr(:)
+ character(len=strlen) :: expect
+ integer, intent(in) :: stop_code
+ integer :: i
+
+ associate(np => num_images())
+ do i = 1, numstrings
+ write (expect, "('foo',I04)") i * np
+ if (curr(i) /= expect) then
+ ! On error print what we got and what we expected.
+ print *, this_image(), ": Got: ", curr(i), ", expected: ", expect, ", for i=", i
+ stop stop_code
+ end if
+ end do
+ end associate
+ end subroutine
+
+end program co_reduce_strings
+
! For this reason, -fcoarray=single and -fcoarray=lib give the
! same result
if (allocated (a[1])) stop 3
- if (allocated (c%x[1,2,3])) stop 4
+ if (allocated (c%x[1,1,1])) stop 4
! Allocate collectively
allocate(a[*])
if (.not. allocated (a)) stop 5
if (.not. allocated (c%x)) stop 6
if (.not. allocated (a[1])) stop 7
- if (.not. allocated (c%x[1,2,3])) stop 8
+ if (.not. allocated (c%x[1,1,1])) stop 8
- ! Deallocate collectively
+ sync all
+ ! Dellocate collectively
deallocate(a)
deallocate(c%x)
if (allocated (a)) stop 9
if (allocated (c%x)) stop 10
if (allocated (a[1])) stop 11
- if (allocated (c%x[1,2,3])) stop 12
+ if (allocated (c%x[1,1,1])) stop 12
end
! Expected: always local access and never a call to _gfortran_caf_get
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = str1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = ustr1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = str2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = ustr2a
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1b
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1b
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2b
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2b
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1a
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1a
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2a
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a = str1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a = ustr1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a = str2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a = ustr2a[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = str1b(:)[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = ustr1b(:)[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = str2b(:)[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = ustr2b(:)[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = str1a[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = ustr1a[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = str2a[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = ustr2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = str1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = str2a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = ustr2a[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1b(:)[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2b(:)[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1a[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1a[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2a[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2a[mod(1, num_images())+1]
end if
str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
- str1a = 1_"XXXXXXX"
+ str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = ustr1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 4_"abc"
ustr2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = str1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = ustr2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 4_"abcde"
ustr1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = str2a
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1b
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1b
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2b
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2b
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1a
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1a
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2a
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a = ustr1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a = str1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a = ustr2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a = str2a[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = ustr1b(:)[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = str1b(:)[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = ustr2b(:)[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = str2b(:)[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = ustr1a[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = str1a[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = ustr2a[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = str2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = str1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = ustr2a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = str2a[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1a[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2a[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2a[mod(1, num_images())+1]
end if
a = 42
s = 42
- ! Checking against single image only. Therefore team statements are
- ! not viable nor are they (yet) supported by GFortran.
+ sync all
+
if (a[1, team_number=-1, stat=s] /= 42) stop 1
if (s /= 0) stop 2
parentteam = get_team()
caf = [23, 32]
- form team(t_num, team, new_index=1)
+ form team(t_num, team) !, new_index=num_images() - this_image() + 1)
form team(t_num, formed_team)
change team(team, cell[*] => caf(2))
- ! for get_from_remote
- ! Checking against caf_single is very limitted.
- if (cell[1, team_number=t_num] /= 32) stop 1
- if (cell[1, team_number=st_num] /= 32) stop 2
- if (cell[1, team=parentteam] /= 32) stop 3
+ associate(me => this_image())
+ ! for get_from_remote
+ ! Checking against caf_single is very limitted.
+ if (cell[me, team_number=t_num] /= 32) stop 1
+ if (cell[me, team_number=st_num] /= 32) stop 2
+ if (cell[me, team=parentteam] /= 32) stop 3
- ! Check that team_number is validated
- lhs = cell[1, team_number=5, stat=stat]
- if (stat /= 1) stop 4
+ ! Check that team_number is validated
+ lhs = cell[me, team_number=5, stat=stat]
+ if (stat /= 1) stop 4
- ! Check that only access to active teams is valid
- stat = 42
- lhs = cell[1, team=formed_team, stat=stat]
- if (stat /= 1) stop 5
+ ! Check that only access to active teams is valid
+ stat = 42
+ lhs = cell[me, team=formed_team, stat=stat]
+ if (stat /= 1) stop 5
- ! for send_to_remote
- ! Checking against caf_single is very limitted.
- cell[1, team_number=t_num] = 45
- if (cell /= 45) stop 11
- cell[1, team_number=st_num] = 46
- if (cell /= 46) stop 12
- cell[1, team=parentteam] = 47
- if (cell /= 47) stop 13
+ ! for send_to_remote
+ ! Checking against caf_single is very limitted.
+ cell[me, team_number=t_num] = 45
+ if (cell /= 45) stop 11
+ cell[me, team_number=st_num] = 46
+ if (cell /= 46) stop 12
+ cell[me, team=parentteam] = 47
+ if (cell /= 47) stop 13
- ! Check that team_number is validated
- stat = -1
- cell[1, team_number=5, stat=stat] = 0
- if (stat /= 1) stop 14
+ ! Check that team_number is validated
+ stat = -1
+ cell[me, team_number=5, stat=stat] = 0
+ if (stat /= 1) stop 14
- ! Check that only access to active teams is valid
- stat = 42
- cell[1, team=formed_team, stat=stat] = -1
- if (stat /= 1) stop 15
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[me, team=formed_team, stat=stat] = -1
+ if (stat /= 1) stop 15
- ! for transfer_between_remotes
- ! Checking against caf_single is very limitted.
- cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
- if (cell /= 23) stop 21
- cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
- ! cell is an alias for caf(2) and has been overwritten by caf(1)!
- if (cell /= 23) stop 22
- cell[1, team=parentteam] = caf(1)[1, team= team]
- if (cell /= 23) stop 23
+ ! for transfer_between_remotes
+ ! Checking against caf_single is very limitted.
+ cell[me, team_number=t_num] = caf(1)[me, team_number=-1]
+ if (cell /= 23) stop 21
+ cell[me, team_number=st_num] = caf(2)[me, team_number=-1]
+ ! cell is an alias for caf(2) and has been overwritten by caf(1)!
+ if (cell /= 23) stop 22
+ cell[me, team=parentteam] = caf(1)[me, team= team]
+ if (cell /= 23) stop 23
- ! Check that team_number is validated
- stat = -1
- cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
- if (stat /= 1) stop 24
- stat = -1
- cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
- if (stat /= 1) stop 25
+ ! Check that team_number is validated
+ stat = -1
+ cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1]
+ if (stat /= 1) stop 24
+ stat = -1
+ cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat]
+ if (stat /= 1) stop 25
- ! Check that only access to active teams is valid
- stat = 42
- cell[1, team=formed_team, stat=stat] = caf(1)[1]
- if (stat /= 1) stop 26
- stat = 42
- cell[1] = caf(1)[1, team=formed_team, stat=stat]
- if (stat /= 1) stop 27
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[me, team=formed_team, stat=stat] = caf(1)[me]
+ if (stat /= 1) stop 26
+ stat = 42
+ cell[me] = caf(1)[me, team=formed_team, stat=stat]
+ if (stat /= 1) stop 27
+
+ sync all
+ end associate
end team
end program coindexed_5
p%i = 42
allocate (p2(5)[*])
p2(:)%i = (/(i, i=0, 4)/)
+ sync all
call s(p, 1)
call s2(p2, 1)
contains
use iso_fortran_env, only: event_type
implicit none
-type(event_type), save :: var[*]
+type(event_type), save, allocatable, dimension(:) :: events[:]
integer :: count, stat
-count = -42
-call event_query (var, count)
-if (count /= 0) STOP 1
-
-stat = 99
-event post (var, stat=stat)
-if (stat /= 0) STOP 2
-call event_query(var, count, stat=stat)
-if (count /= 1 .or. stat /= 0) STOP 3
-
-stat = 99
-event post (var[this_image()])
-call event_query(var, count)
-if (count /= 2) STOP 4
-
-stat = 99
-event wait (var)
-call event_query(var, count)
-if (count /= 1) STOP 5
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 2) STOP 6
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 3) STOP 7
-
-stat = 99
-event wait (var, until_count=2)
-call event_query(var, count)
-if (count /= 1) STOP 8
-
-stat = 99
-event wait (var, stat=stat, until_count=1)
-if (stat /= 0) STOP 9
-call event_query(event=var, stat=stat, count=count)
-if (count /= 0 .or. stat /= 0) STOP 10
+associate (me => this_image(), np => num_images())
+ allocate(events(np)[*])
+
+ associate(var => events(me))
+ count = -42
+ call event_query (var, count)
+ if (count /= 0) STOP 1
+
+ stat = 99
+ event post (var, stat=stat)
+ if (stat /= 0) STOP 2
+ call event_query(var, count, stat=stat)
+ if (count /= 1 .or. stat /= 0) STOP 3
+
+ count = 99
+ event post (var[this_image()])
+ call event_query(var, count)
+ if (count /= 2) STOP 4
+
+ count = 99
+ event wait (var)
+ call event_query(var, count)
+ if (count /= 1) STOP 5
+
+ count = 99
+ event post (var)
+ call event_query(var, count)
+ if (count /= 2) STOP 6
+
+ count = 99
+ event post (var)
+ call event_query(var, count)
+ if (count /= 3) STOP 7
+
+ count = 99
+ event wait (var, until_count=2)
+ call event_query(var, count)
+ if (count /= 1) STOP 8
+
+ stat = 99
+ event wait (var, stat=stat, until_count=1)
+ if (stat /= 0) STOP 9
+ count = 99
+ call event_query(event=var, stat=stat, count=count)
+ if (count /= 0 .or. stat /= 0) STOP 10
+ end associate
+end associate
end
contains
subroutine exchange
integer :: cnt
- event post(x[1])
- event post(x[1])
+ event post(x[this_image()])
+ event post(x[this_image()])
call event_query(x, cnt)
if (cnt /= 2) error stop 1
event wait(x, until_count=2)
type(event_type) done[*]
nc(1) = 1
event post(done[1])
- event wait(done,until_count=nc(1))
+ if (this_image() == 1) event wait(done,until_count=nc(1))
+ sync all
end
integer :: i
fi = failed_images() ! OK
- fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" }
+ fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
fi = failed_images(KIND=1) ! OK
fi = failed_images(KIND=4) ! OK
fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" }
! { dg-do run }
program test_failed_images_2
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
integer, allocatable :: fi(:)
integer(kind=1), allocatable :: sfi(:)
+ integer, allocatable :: rem_images(:)
+ integer :: i, st
- fi = failed_images()
- if (size(fi) > 0) error stop "failed_images result shall be empty array"
- sfi = failed_images(KIND=1)
- if (size(sfi) > 0) error stop "failed_images result shall be empty array"
- sfi = failed_images(KIND=8)
- if (size(sfi) > 0) error stop "failed_images result shall be empty array"
+ associate(np => num_images())
+ form team (1, t)
+ fi = failed_images()
+ if (size(fi) > 0) stop 1
+ sfi = failed_images(KIND=1)
+ if (size(sfi) > 0) stop 2
+ sfi = failed_images(KIND=8)
+ if (size(sfi) > 0) stop 3
+
+ fi = failed_images(t)
+ if (size(fi) > 0) stop 4
+ if (num_images() > 1) then
+ sync all
+ if (this_image() == 2) fail image
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on a failed image. Try with a sleep.
+ do i = 0, 10
+ if (size(failed_images()) == 0) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ if (i == 10 .AND. size(failed_images()) == 0) stop 5
+ sync images (rem_images, stat=st)
+ if (any(failed_images() /= [2])) stop 6
+ if (any(failed_images(t, 8) /= [2])) stop 7
+ end if
+ end associate
end program test_failed_images_2
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
- isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
+ isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" }
isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
! { dg-do run }
program test_image_status_2
- use iso_fortran_env , only : STAT_STOPPED_IMAGE
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
+ integer :: i, st
+ integer, allocatable :: rem_images(:)
+
+ form team (1, t)
+
if (image_status(1) /= 0) error stop "Image 1 should report OK."
- if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped."
- if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
+ if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped."
+
+ if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK."
+
+ if (num_images() > 1) then
+ associate (np => num_images())
+ sync all
+ if (this_image() == 2) fail image
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on failed image. Try with a sleep.
+ do i = 0, 10
+ if (image_status(2) /= STAT_FAILED_IMAGE) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ sync images (rem_images, stat=st)
+ if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+ if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+ end associate
+ end if
end program test_image_status_2
UNLOCK(lock3(4), stat=stat)
if (stat /= 0) STOP 10
+! Ensure all other (/=1) images have released the locks.
+sync all
if (this_image() == 1) then
acquired = .false.
LOCK (lock1[this_image()], acquired_lock=acquired)
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 1
if (any (lcobound(a) /= 1)) STOP 2
-if (any (ucobound(a) /= this_image())) STOP 3
+if (any (ucobound(a) /= num_images())) STOP 3
deallocate(a)
allocate(b[*])
if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
STOP 4
if (any (lcobound(b) /= 1)) STOP 5
-if (any (ucobound(b) /= this_image())) STOP 6
+if (any (ucobound(b) /= num_images())) STOP 6
deallocate(b)
allocate(a(1)[-10:*])
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 7
if (any (lcobound(a) /= -10)) STOP 8
-if (any (ucobound(a) /= -11+this_image())) STOP 9
+if (any (ucobound(a) /= -11 + num_images())) STOP 9
deallocate(a)
allocate(d[23:*])
if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
STOP 10
if (any (lcobound(d) /= 23)) STOP 11
-if (any (ucobound(d) /= 22+this_image())) STOP 12
+if (any (ucobound(d) /= 22 + num_images())) STOP 12
deallocate(d)
end
deallocate(a)
allocate(a[4:*])
-a[this_image ()] = 8 - 2*this_image ()
+a[this_image () + 3] = 8 - 2*this_image ()
if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
STOP 4
allocate (B[n1:n2, n3:*])
if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) &
STOP 5
+sync all
call sub(A, B)
if (allocated (a)) STOP 6
STOP 8
if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
STOP 9
- if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
+ if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10
+ sync all
deallocate(x)
end subroutine sub
integer, allocatable, SAVE :: a[:]
if (init) then
- if (allocated(a)) STOP 10
+ if (allocated(a)) STOP 11
allocate(a[*])
a = 45
else
- if (.not. allocated(a)) STOP 11
- if (a /= 45) STOP 12
+ if (.not. allocated(a)) STOP 12
+ if (a /= 45) STOP 13
+ sync all
deallocate(a)
end if
end subroutine two
integer :: i
gi = stopped_images() ! OK
- gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" }
+ gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
gi = stopped_images(KIND=1) ! OK
gi = stopped_images(KIND=4) ! OK
gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" }
! { dg-do run }
program test_stopped_images_2
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
integer, allocatable :: si(:)
integer(kind=1), allocatable :: ssi(:)
+ integer, allocatable :: rem_images(:)
+ integer :: i, st
- si = stopped_images()
- if (size(si) > 0) error stop "stopped_images result shall be empty array"
- ssi = stopped_images(KIND=1)
- if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
- ssi = stopped_images(KIND=8)
- if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
+ associate(np => num_images())
+ form team (1, t)
+ si = stopped_images()
+ if (size(si) > 0) stop 1
+ ssi = stopped_images(KIND=1)
+ if (size(ssi) > 0) stop 2
+ ssi = stopped_images(KIND=8)
+ if (size(ssi) > 0) stop 3
+
+ si = stopped_images(t)
+ if (size(si) > 0) stop 4
+ if (num_images() > 1) then
+ sync all
+ if (this_image() == 2) stop
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on a stopped image. Try with a sleep.
+ do i = 0, 10
+ if (size(stopped_images()) == 0) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ if (i == 10 .AND. size(stopped_images()) == 0) stop 5
+ sync images (rem_images, stat=st)
+ if (any(stopped_images() /= [2])) stop 6
+ if (any(stopped_images(t, 8) /= [2])) stop 7
+ end if
+ end associate
end program test_stopped_images_2
sync all (stat=n,errmsg=str)
if (n /= 0) STOP 2
-
!
! Test SYNC MEMORY
!
sync memory (errmsg=str,stat=n)
if (n /= 0) STOP 4
-
!
! Test SYNC IMAGES
!
sync images (*)
+
if (this_image() == 1) then
sync images (1)
sync images (1, errmsg=str)
sync images ([1])
end if
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
n = 5
sync images (*, stat=n)
if (n /= 0) STOP 5
sync images (*,errmsg=str,stat=n)
if (n /= 0) STOP 6
+sync all
end
! PR fortran/18918
implicit none
-integer :: n
-character(len=30) :: str
+integer :: n, st
+integer,allocatable :: others(:)
+character(len=40) :: str
critical
end critical
myCr: critical
sync images ([1])
end if
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
n = 5
sync images (*, stat=n)
if (n /= 0) STOP 5
n = 5
-sync images (*,errmsg=str,stat=n)
+sync images (*, errmsg=str, stat=n)
if (n /= 0) STOP 6
+if (this_image() == num_images()) then
+ others = (/( n, n=1, (num_images() - 1)) /)
+ sync images(others)
+else
+ sync images ( num_images() )
+end if
+
n = -1
-sync images ( num_images() )
-sync images (n) ! Invalid: "-1"
+st = 0
+sync images (n, errmsg=str, stat=st)
+if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7
+
+! Do this only on image 1, or output of error messages will clutter
+if (this_image() == 1) sync images (n) ! Invalid: "-1"
end
--- /dev/null
+!{ dg-do run }
+
+program main
+ use, intrinsic :: iso_fortran_env, only: team_type
+ implicit none
+ integer, parameter :: PARENT_TEAM = 1, CURRENT_TEAM = 2, CHILD_TEAM = 3
+ type(team_type) :: team(3)
+
+ if (num_images() > 7) then
+
+ form team (1, team(PARENT_TEAM))
+ change team (team(PARENT_TEAM))
+ form team (mod(this_image(),2) + 1, team(CURRENT_TEAM))
+ change team (team(CURRENT_TEAM))
+ form team(mod(this_image(),2) + 1, team(CHILD_TEAM))
+ sync team(team(PARENT_TEAM))
+ ! change order / number of syncs between teams to try to expose deadlocks
+ if (team_number() == 1) then
+ sync team(team(CURRENT_TEAM))
+ sync team(team(CHILD_TEAM))
+ else
+ sync team(team(CHILD_TEAM))
+ sync team(team(CURRENT_TEAM))
+ sync team(team(CHILD_TEAM))
+ sync team(team(CURRENT_TEAM))
+ end if
+ end team
+ end team
+
+ sync all
+ end if
+
+end program
! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, 0B, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, &&msg, 42\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, &&msg, 42\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, &msg, 42\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, &msg, 42\\);" 1 "original" } }
$(version_arg) -Wc,-shared-libgcc
libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
-cafexeclib_LTLIBRARIES = libcaf_single.la
+libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
+libcaf_shared_SRCS = caf/caf_error.c
+
+cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c
+libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = caf/libcaf.h
+libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
+libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
+ caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
+ caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
+ caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
+ caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
+
+libcaf_shmem_la_LDFLAGS = -static
+libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
+ caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
+ caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
+ caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
+ caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
+libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
+
if IEEE_SUPPORT
fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
"$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \
"$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)"
LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
-libcaf_single_la_LIBADD =
+libcaf_shmem_la_LIBADD =
am__dirstamp = $(am__leading_dot)dirstamp
-am_libcaf_single_la_OBJECTS = caf/single.lo
+am__objects_1 = caf/caf_error.lo
+am_libcaf_shmem_la_OBJECTS = $(am__objects_1) caf/shmem.lo \
+ caf/shmem/alloc.lo caf/shmem/allocator.lo \
+ caf/shmem/collective_subroutine.lo \
+ caf/shmem/counter_barrier.lo caf/shmem/hashmap.lo \
+ caf/shmem/shared_memory.lo caf/shmem/supervisor.lo \
+ caf/shmem/sync.lo caf/shmem/teams_mgmt.lo \
+ caf/shmem/thread_support.lo
+libcaf_shmem_la_OBJECTS = $(am_libcaf_shmem_la_OBJECTS)
+libcaf_single_la_LIBADD =
+am_libcaf_single_la_OBJECTS = caf/single.lo $(am__objects_1)
libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS)
libgfortran_la_LIBADD =
-@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_2 = runtime/backtrace.lo \
+@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo
+@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/convert_char.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/environ.lo runtime/error.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/fpu.lo runtime/main.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/pause.lo runtime/stop.lo
-am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \
+am__objects_4 = runtime/bounds.lo runtime/compile_options.lo \
runtime/memory.lo runtime/string.lo runtime/select.lo \
- $(am__objects_1) $(am__objects_2)
-am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
+ $(am__objects_2) $(am__objects_3)
+am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \
generated/matmul_i4.lo generated/matmul_i8.lo \
generated/matmul_i16.lo generated/matmul_r4.lo \
generated/matmul_r8.lo generated/matmul_r10.lo \
generated/matmul_c4.lo generated/matmul_c8.lo \
generated/matmul_c10.lo generated/matmul_c16.lo \
generated/matmul_c17.lo
-am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \
+am__objects_6 = generated/matmul_l4.lo generated/matmul_l8.lo \
generated/matmul_l16.lo
-am__objects_6 = generated/matmulavx128_i1.lo \
+am__objects_7 = generated/matmulavx128_i1.lo \
generated/matmulavx128_i2.lo generated/matmulavx128_i4.lo \
generated/matmulavx128_i8.lo generated/matmulavx128_i16.lo \
generated/matmulavx128_r4.lo generated/matmulavx128_r8.lo \
generated/matmulavx128_r17.lo generated/matmulavx128_c4.lo \
generated/matmulavx128_c8.lo generated/matmulavx128_c10.lo \
generated/matmulavx128_c16.lo generated/matmulavx128_c17.lo
-am__objects_7 = generated/all_l1.lo generated/all_l2.lo \
+am__objects_8 = generated/all_l1.lo generated/all_l2.lo \
generated/all_l4.lo generated/all_l8.lo generated/all_l16.lo \
generated/any_l1.lo generated/any_l2.lo generated/any_l4.lo \
generated/any_l8.lo generated/any_l16.lo \
generated/pow_m8_m16.lo generated/pow_m16_m1.lo \
generated/pow_m16_m2.lo generated/pow_m16_m4.lo \
generated/pow_m16_m8.lo generated/pow_m16_m16.lo \
- $(am__objects_4) $(am__objects_5) $(am__objects_6) \
+ $(am__objects_5) $(am__objects_6) $(am__objects_7) \
runtime/ISO_Fortran_binding.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_8 = io/close.lo io/file_pos.lo \
+@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \
@LIBGFOR_MINIMAL_FALSE@ io/format.lo io/inquire.lo \
@LIBGFOR_MINIMAL_FALSE@ io/intrinsics.lo io/list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ io/lock.lo io/open.lo io/read.lo \
@LIBGFOR_MINIMAL_FALSE@ io/transfer.lo io/transfer128.lo \
@LIBGFOR_MINIMAL_FALSE@ io/unit.lo io/unix.lo io/write.lo \
@LIBGFOR_MINIMAL_FALSE@ io/fbuf.lo io/async.lo
-am__objects_9 = io/size_from_kind.lo $(am__objects_8)
-@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \
+am__objects_10 = io/size_from_kind.lo $(am__objects_9)
+@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/chdir.lo intrinsics/chmod.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/clock.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/system_clock.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/time.lo intrinsics/umask.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/unlink.lo
-@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo
-am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
+@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.lo
+am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \
intrinsics/args.lo intrinsics/cshift0.lo \
intrinsics/eoshift0.lo intrinsics/eoshift2.lo \
intrinsics/erfc_scaled.lo intrinsics/extends_type_of.lo \
intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
- runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11)
-@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \
+ runtime/in_unpack_class.lo $(am__objects_11) $(am__objects_12)
+@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo
-am__objects_14 =
-am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \
+am__objects_15 =
+am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \
generated/_abs_c10.lo generated/_abs_c16.lo \
generated/_abs_c17.lo generated/_abs_i4.lo \
generated/_abs_i8.lo generated/_abs_i16.lo \
generated/_mod_r17.lo generated/misc_specifics.lo \
intrinsics/dprod_r8.lo intrinsics/f2c_specifics.lo \
intrinsics/random_init.lo
-am_libgfortran_la_OBJECTS = $(am__objects_3) $(am__objects_7) \
- $(am__objects_9) $(am__objects_12) $(am__objects_13) \
- $(am__objects_14) $(am__objects_15)
+am_libgfortran_la_OBJECTS = $(am__objects_4) $(am__objects_8) \
+ $(am__objects_10) $(am__objects_13) $(am__objects_14) \
+ $(am__objects_15) $(am__objects_16)
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
AM_V_P = $(am__v_P_@AM_V@)
am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
am__v_FC_ = $(am__v_FC_@AM_DEFAULT_V@)
am__v_FC_0 = @echo " FC " $@;
am__v_FC_1 =
-SOURCES = $(libcaf_single_la_SOURCES) $(libgfortran_la_SOURCES)
+SOURCES = $(libcaf_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \
+ $(libgfortran_la_SOURCES)
am__can_run_installinfo = \
case $$AM_UPDATE_INFO_DIR in \
n|no|NO) false;; \
$(version_arg) -Wc,-shared-libgcc
libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
-cafexeclib_LTLIBRARIES = libcaf_single.la
+libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
+libcaf_shared_SRCS = caf/caf_error.c
+cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c
+libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = caf/libcaf.h
+libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
+libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
+ caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
+ caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
+ caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
+ caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
+
+libcaf_shmem_la_LDFLAGS = -static
+libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
+ caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
+ caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
+ caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
+ caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
+
+libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
@IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
@IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
caf/$(DEPDIR)/$(am__dirstamp):
@$(MKDIR_P) caf/$(DEPDIR)
@: > caf/$(DEPDIR)/$(am__dirstamp)
+caf/caf_error.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
+caf/shmem.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/$(am__dirstamp):
+ @$(MKDIR_P) caf/shmem
+ @: > caf/shmem/$(am__dirstamp)
+caf/shmem/$(DEPDIR)/$(am__dirstamp):
+ @$(MKDIR_P) caf/shmem/$(DEPDIR)
+ @: > caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/alloc.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/allocator.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/collective_subroutine.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/counter_barrier.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/hashmap.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/shared_memory.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/supervisor.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/sync.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/teams_mgmt.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+caf/shmem/thread_support.lo: caf/shmem/$(am__dirstamp) \
+ caf/shmem/$(DEPDIR)/$(am__dirstamp)
+
+libcaf_shmem.la: $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_DEPENDENCIES) $(EXTRA_libcaf_shmem_la_DEPENDENCIES)
+ $(AM_V_GEN)$(libcaf_shmem_la_LINK) -rpath $(cafexeclibdir) $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_LIBADD) $(LIBS)
caf/single.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp)
-libcaf_single.la: $(libcaf_single_la_OBJECTS) $(libcaf_single_la_DEPENDENCIES) $(EXTRA_libcaf_single_la_DEPENDENCIES)
+libcaf_single.la: $(libcaf_single_la_OBJECTS) $(libcaf_single_la_DEPENDENCIES) $(EXTRA_libcaf_single_la_DEPENDENCIES)
$(AM_V_GEN)$(libcaf_single_la_LINK) -rpath $(cafexeclibdir) $(libcaf_single_la_OBJECTS) $(libcaf_single_la_LIBADD) $(LIBS)
runtime/$(am__dirstamp):
@$(MKDIR_P) runtime
-rm -f *.$(OBJEXT)
-rm -f caf/*.$(OBJEXT)
-rm -f caf/*.lo
+ -rm -f caf/shmem/*.$(OBJEXT)
+ -rm -f caf/shmem/*.lo
-rm -f generated/*.$(OBJEXT)
-rm -f generated/*.lo
-rm -f ieee/*.$(OBJEXT)
distclean-compile:
-rm -f *.tab.c
+@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/caf_error.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/shmem.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/single.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/alloc.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/allocator.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/collective_subroutine.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/counter_barrier.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/hashmap.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/shared_memory.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/supervisor.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/sync.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/teams_mgmt.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/thread_support.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l2.Plo@am__quote@
clean-libtool:
-rm -rf .libs _libs
-rm -rf caf/.libs caf/_libs
+ -rm -rf caf/shmem/.libs caf/shmem/_libs
-rm -rf generated/.libs generated/_libs
-rm -rf ieee/.libs ieee/_libs
-rm -rf intrinsics/.libs intrinsics/_libs
-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
-rm -f caf/$(DEPDIR)/$(am__dirstamp)
-rm -f caf/$(am__dirstamp)
+ -rm -f caf/shmem/$(DEPDIR)/$(am__dirstamp)
+ -rm -f caf/shmem/$(am__dirstamp)
-rm -f generated/$(DEPDIR)/$(am__dirstamp)
-rm -f generated/$(am__dirstamp)
-rm -f ieee/$(DEPDIR)/$(am__dirstamp)
distclean: distclean-am
-rm -f $(am__CONFIG_DISTCLEAN_FILES)
- -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+ -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -f Makefile
distclean-am: clean-am distclean-compile distclean-generic \
distclean-hdr distclean-libtool distclean-local distclean-tags
maintainer-clean: maintainer-clean-am
-rm -f $(am__CONFIG_DISTCLEAN_FILES)
-rm -rf $(top_srcdir)/autom4te.cache
- -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+ -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -f Makefile
maintainer-clean-am: distclean-am maintainer-clean-generic \
maintainer-clean-local
--- /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
void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, size_t);
void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
-void _gfortran_caf_failed_images (gfc_descriptor_t *,
- caf_team_t * __attribute__ ((unused)), int *);
-int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused)));
-void _gfortran_caf_stopped_images (gfc_descriptor_t *,
- caf_team_t * __attribute__ ((unused)),
- int *);
+void _gfortran_caf_failed_images (gfc_descriptor_t *, caf_team_t *, int *);
+int _gfortran_caf_image_status (int, caf_team_t *);
+void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *);
void _gfortran_caf_random_init (bool, bool);
--- /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 <unistd.h>
+#include <string.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
*stat = 1;
if (errmsg_len > 0)
{
- int len = snprintf (errmsg, errmsg_len, msg, args);
+ int len = vsnprintf (errmsg, errmsg_len, msg, args);
if (len >= 0 && errmsg_len > (size_t) len)
memset (&errmsg[len], ' ', errmsg_len - len);
}
projects / thirdparty / gcc.git / commitdiff
