|| !positive_check (0, image))
return false;
- return !team || (scalar_check (team, 1) && team_type_check (team, 1));
+ return !team || (scalar_check (team, 0) && team_type_check (team, 0));
}
bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{
- if (team && (!scalar_check (team, 0) || !team_type_check (team, 0)))
- return false;
+ 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 (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))
- {
- /* 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
- /* Extract the expression, evaluate it and add a temporary with its
- value to the helper structure. */
+ 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);
+ else
+ for (gfc_actual_arglist *actual = e->value.function.actual; actual;
+ actual = actual->next)
+ check_add_new_component (type, actual->expr, 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, pvoid_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_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);
- 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));
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 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 lhs_dim, rhs_dim, type;
+ tree tmp, tmp2, 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. */
- 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);
+ tmp = gfc_get_descriptor_dimension (lhs_desc);
+ tmp2 = gfc_get_descriptor_dimension (rhs_desc);
- /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
- copy_coarray_desc_part (block, lhs_desc, rhs_desc);
+ 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);
}
/* 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
- : gfc_build_addr_expr (NULL_TREE, args[1]));
+ num_args < 2 ? null_pointer_node : args[1]);
else
gcc_unreachable ();
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
- images = gfc_trans_force_lval (&argse.pre, argse.expr);
- gfc_add_block_to_block (&se.pre, &argse.pre);
+ images = argse.expr;
}
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 = argse.expr;
+ errmsg = gfc_build_addr_expr (NULL, 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, other
+ integer :: me
me=this_image()
- 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
+ allocate(object%indices(me))
+ object%indices = 42
- sync all
- if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1
- sync all
+ if ( any( object[me]%indices(:) /= 42 ) ) STOP 1
end program
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() * 2) STOP 12
+if (stat /= 0 .or. var /= num_images() + this_image()) 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() * 2) STOP 45
+if (stat /= 0 .or. var /= num_images() + this_image()) 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) STOP 53
+ if (stat /= 0 .or. var <= 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) STOP 68
+ if (stat /= 0 .or. (var < 0 .and. var /= -1)) 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
-sync all
+if (stat /= 0 .or. var2 .neqv. .false.) STOP 89
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,1,1])) stop 4
+ if (allocated (c%x[1,2,3])) 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,1,1])) stop 8
+ if (.not. allocated (c%x[1,2,3])) stop 8
- sync all
- ! Dellocate collectively
+ ! Deallocate 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,1,1])) stop 12
+ if (allocated (c%x[1,2,3])) 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"
- str2a = 1_"XXXXXXX"
- sync all
+ str1a = 1_"XXXXXXX"
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
- sync all
-
+ ! Checking against single image only. Therefore team statements are
+ ! not viable nor are they (yet) supported by GFortran.
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=num_images() - this_image() + 1)
+ form team(t_num, team, new_index=1)
form team(t_num, formed_team)
change team(team, cell[*] => caf(2))
- 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
+ ! 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
- ! Check that team_number is validated
- lhs = cell[me, team_number=5, stat=stat]
- if (stat /= 1) stop 4
+ ! Check that team_number is validated
+ lhs = cell[1, team_number=5, stat=stat]
+ if (stat /= 1) stop 4
- ! Check that only access to active teams is valid
- stat = 42
- lhs = cell[me, team=formed_team, stat=stat]
- if (stat /= 1) stop 5
+ ! Check that only access to active teams is valid
+ stat = 42
+ lhs = cell[1, team=formed_team, stat=stat]
+ if (stat /= 1) stop 5
- ! 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
+ ! 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
- ! Check that team_number is validated
- stat = -1
- cell[me, team_number=5, stat=stat] = 0
- if (stat /= 1) stop 14
+ ! Check that team_number is validated
+ stat = -1
+ cell[1, team_number=5, stat=stat] = 0
+ if (stat /= 1) stop 14
- ! Check that only access to active teams is valid
- stat = 42
- cell[me, team=formed_team, stat=stat] = -1
- if (stat /= 1) stop 15
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[1, team=formed_team, stat=stat] = -1
+ if (stat /= 1) stop 15
- ! 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
+ ! 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
- ! 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 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 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
+ ! 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
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, allocatable, dimension(:) :: events[:]
+type(event_type), save :: var[*]
integer :: count, stat
-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
+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
end
contains
subroutine exchange
integer :: cnt
- event post(x[this_image()])
- event post(x[this_image()])
+ event post(x[1])
+ event post(x[1])
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])
- if (this_image() == 1) event wait(done,until_count=nc(1))
- sync all
+ event wait(done,until_count=nc(1))
end
integer :: i
fi = failed_images() ! OK
- 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(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" }
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
- 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
+ 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"
- 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 "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" }
+ isv = image_status(1, team=1) ! { dg-error "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
+ use iso_fortran_env , only : STAT_STOPPED_IMAGE
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(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
+ 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."
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) /= num_images())) STOP 3
+if (any (ucobound(a) /= this_image())) 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) /= num_images())) STOP 6
+if (any (ucobound(b) /= this_image())) 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 + num_images())) STOP 9
+if (any (ucobound(a) /= -11+this_image())) 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 + num_images())) STOP 12
+if (any (ucobound(d) /= 22+this_image())) STOP 12
deallocate(d)
end
deallocate(a)
allocate(a[4:*])
-a[this_image () + 3] = 8 - 2*this_image ()
+a[this_image ()] = 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 () + 3] /= 8 - 2*this_image ()) STOP 10
- sync all
+ if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
deallocate(x)
end subroutine sub
integer, allocatable, SAVE :: a[:]
if (init) then
- if (allocated(a)) STOP 11
+ if (allocated(a)) STOP 10
allocate(a[*])
a = 45
else
- if (.not. allocated(a)) STOP 12
- if (a /= 45) STOP 13
- sync all
+ if (.not. allocated(a)) STOP 11
+ if (a /= 45) STOP 12
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\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
+ gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" }
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
- 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
+ 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"
- 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, st
-integer,allocatable :: others(:)
-character(len=40) :: str
+integer :: n
+character(len=30) :: 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
-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"
+sync images ( num_images() )
+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)
-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
+cafexeclib_LTLIBRARIES = libcaf_single.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
+libcaf_single_la_SOURCES = caf/single.c
libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
+libcaf_single_la_DEPENDENCIES = caf/libcaf.h
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_shmem_la_LIBADD =
-am__dirstamp = $(am__leading_dot)dirstamp
-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)
+am__dirstamp = $(am__leading_dot)dirstamp
+am_libcaf_single_la_OBJECTS = caf/single.lo
libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS)
libgfortran_la_LIBADD =
-@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \
+@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo
+@LIBGFOR_MINIMAL_FALSE@am__objects_2 = 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_4 = runtime/bounds.lo runtime/compile_options.lo \
+am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \
runtime/memory.lo runtime/string.lo runtime/select.lo \
- $(am__objects_2) $(am__objects_3)
-am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \
+ $(am__objects_1) $(am__objects_2)
+am__objects_4 = 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_6 = generated/matmul_l4.lo generated/matmul_l8.lo \
+am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \
generated/matmul_l16.lo
-am__objects_7 = generated/matmulavx128_i1.lo \
+am__objects_6 = 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_8 = generated/all_l1.lo generated/all_l2.lo \
+am__objects_7 = 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_5) $(am__objects_6) $(am__objects_7) \
+ $(am__objects_4) $(am__objects_5) $(am__objects_6) \
runtime/ISO_Fortran_binding.lo
-@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \
+@LIBGFOR_MINIMAL_FALSE@am__objects_8 = 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_10 = io/size_from_kind.lo $(am__objects_9)
-@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \
+am__objects_9 = io/size_from_kind.lo $(am__objects_8)
+@LIBGFOR_MINIMAL_FALSE@am__objects_10 = 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_12 = ieee/ieee_helper.lo
-am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \
+@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo
+am__objects_12 = 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_11) $(am__objects_12)
-@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \
+ runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11)
+@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo
-am__objects_15 =
-am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \
+am__objects_14 =
+am__objects_15 = 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_4) $(am__objects_8) \
- $(am__objects_10) $(am__objects_13) $(am__objects_14) \
- $(am__objects_15) $(am__objects_16)
+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)
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_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \
- $(libgfortran_la_SOURCES)
+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)
-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
+cafexeclib_LTLIBRARIES = libcaf_single.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
-libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
+libcaf_single_la_SOURCES = caf/single.c
libcaf_single_la_LDFLAGS = -static
-libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
+libcaf_single_la_DEPENDENCIES = caf/libcaf.h
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) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+ -rm -rf caf/$(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) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
+ -rm -rf caf/$(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 *, 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_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_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 = vsnprintf (errmsg, errmsg_len, msg, args);
+ int len = snprintf (errmsg, errmsg_len, msg, args);
if (len >= 0 && errmsg_len > (size_t) len)
memset (&errmsg[len], ' ', errmsg_len - len);
}
projects / thirdparty / gcc.git / commitdiff
