git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fortran: Andre's coarray patch series, ver 4 

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_image_status): mod
	(gfc_check_failed_or_stopped_images): mod
	* invoke.texi: mod
	* trans-expr.cc (get_scalar_to_descriptor_type): mod
	(copy_coarray_desc_part): mod
	(gfc_class_array_data_assign): mod
	(gfc_conv_derived_to_class): mod
	* trans-intrinsic.cc (conv_intrinsic_image_status): mod
	* trans-stmt.cc (gfc_trans_sync): mod

libgfortran/ChangeLog:

	* Makefile.am: mod
	* Makefile.in: mod
	* acinclude.m4: mod
	* caf/libcaf.h (LIBCAF_H): mod
	(_gfortran_caf_failed_images): mod
	(_gfortran_caf_image_status): mod
	(_gfortran_caf_stopped_images): mod
	* caf/single.c (caf_internal_error): mod
	* config.h.in: Regenerate.
	* configure: Regenerate.
	* configure.ac: mod
	* caf/caf_error.c: New file.
	* caf/caf_error.h: New file.
	* caf/shmem.c: New file.
	* caf/shmem/alloc.c: New file.
	* caf/shmem/alloc.h: New file.
	* caf/shmem/allocator.c: New file.
	* caf/shmem/allocator.h: New file.
	* caf/shmem/collective_subroutine.c: New file.
	* caf/shmem/collective_subroutine.h: New file.
	* caf/shmem/counter_barrier.c: New file.
	* caf/shmem/counter_barrier.h: New file.
	* caf/shmem/hashmap.c: New file.
	* caf/shmem/hashmap.h: New file.
	* caf/shmem/shared_memory.c: New file.
	* caf/shmem/shared_memory.h: New file.
	* caf/shmem/supervisor.c: New file.
	* caf/shmem/supervisor.h: New file.
	* caf/shmem/sync.c: New file.
	* caf/shmem/sync.h: New file.
	* caf/shmem/teams_mgmt.c: New file.
	* caf/shmem/teams_mgmt.h: New file.
	* caf/shmem/thread_support.c: New file.
	* caf/shmem/thread_support.h: New file.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/alloc_comp_4.f90: mod
	* gfortran.dg/coarray/atomic_2.f90: mod
	* gfortran.dg/coarray/caf.exp: mod
	* gfortran.dg/coarray/coarray_allocated.f90: mod
	* gfortran.dg/coarray/coindexed_1.f90: mod
	* gfortran.dg/coarray/coindexed_3.f08: mod
	* gfortran.dg/coarray/coindexed_5.f90: mod
	* gfortran.dg/coarray/dummy_3.f90: mod
	* gfortran.dg/coarray/event_1.f90: mod
	* gfortran.dg/coarray/event_3.f08: mod
	* gfortran.dg/coarray/event_4.f08: mod
	* gfortran.dg/coarray/failed_images_1.f08: mod
	* gfortran.dg/coarray/failed_images_2.f08: mod
	* gfortran.dg/coarray/image_status_1.f08: mod
	* gfortran.dg/coarray/image_status_2.f08: mod
	* gfortran.dg/coarray/lock_2.f90: mod
	* gfortran.dg/coarray/poly_run_3.f90: mod
	* gfortran.dg/coarray/scalar_alloc_1.f90: mod
	* gfortran.dg/coarray/stopped_images_1.f08: mod
	* gfortran.dg/coarray/stopped_images_2.f08: mod
	* gfortran.dg/coarray/sync_1.f90: mod
	* gfortran.dg/coarray/sync_3.f90: mod
	* gfortran.dg/coarray_sync_memory.f90: mod
	* gfortran.dg/coarray/co_reduce_string.f90: New test.
	* gfortran.dg/coarray/sync_team.f90: New test.
This commit is contained in:
Jerry DeLisle 2025-10-02 17:10:07 -07:00
parent 9933391746
commit 325fe22620
61 changed files with 6493 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/check.cc
View File

@ -1865,7 +1865,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
|| !positive_check (0, image))
return false;
return !team || (scalar_check (team, 0) && team_type_check (team, 0));
return !team || (scalar_check (team, 1) && team_type_check (team, 1));
}
@ -1908,13 +1908,8 @@ gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis)
bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{
if (team)
{
gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&team->where);
return false;
}
if (team && (!scalar_check (team, 0) || !team_type_check (team, 0)))
return false;
if (kind)
{

63
gcc/fortran/invoke.texi
View File

@ -104,6 +104,7 @@ one is not the default.
* 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
@ -2294,3 +2295,65 @@ variables.
@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!
@env{GFORTRAN_IMAGE_RESTARTS_LIMIT}: On certain platforms, esp. MacOS, the
shared memory segment needs to be placed on the same (virtual) address in every
image or synchronisation primitives do not work as expected. Unfortunately are
some OSes somewhat arbitrary on when they can do this. When the OS is not able
to fullfill the request, then the image aborts itsself and is restarted by the
supervisor untill the OS complies. This environment variable limits the total
number of restarts of all images having an issue with shared memory segment
placement. The default value is 4000.
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

68
gcc/fortran/trans-expr.cc
View File

@ -90,6 +90,8 @@ static tree
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;
@ -100,8 +102,16 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
if (POINTER_TYPE_P (TREE_TYPE (scalar)))
scalar = TREE_TYPE (scalar);
return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
akind, !(attr.pointer || attr.target));
if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)))
{
struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar));
codim = lang_specific->corank;
lbound = lang_specific->lbound;
ubound = lang_specific->ubound;
}
return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound,
ubound, 1, akind,
!(attr.pointer || attr.target));
}
tree
@ -781,11 +791,43 @@ gfc_get_vptr_from_expr (tree expr)
return NULL_TREE;
}
static void
copy_coarray_desc_part (stmtblock_t *block, tree dest, tree src)
{
tree src_type = TREE_TYPE (src);
if (TYPE_LANG_SPECIFIC (src_type) && TYPE_LANG_SPECIFIC (src_type)->corank)
{
struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (src_type);
for (int c = 0; c < lang_specific->corank; ++c)
{
int dim = lang_specific->rank + c;
tree codim = gfc_rank_cst[dim];
if (lang_specific->lbound[dim])
gfc_conv_descriptor_lbound_set (block, dest, codim,
lang_specific->lbound[dim]);
else
gfc_conv_descriptor_lbound_set (
block, dest, codim, gfc_conv_descriptor_lbound_get (src, codim));
if (dim + 1 < lang_specific->corank)
{
if (lang_specific->ubound[dim])
gfc_conv_descriptor_ubound_set (block, dest, codim,
lang_specific->ubound[dim]);
else
gfc_conv_descriptor_ubound_set (
block, dest, codim,
gfc_conv_descriptor_ubound_get (src, codim));
}
}
}
}
void
gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
bool lhs_type)
{
tree tmp, tmp2, type;
tree lhs_dim, rhs_dim, type;
gfc_conv_descriptor_data_set (block, lhs_desc,
gfc_conv_descriptor_data_get (rhs_desc));
@ -796,15 +838,18 @@ gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
gfc_conv_descriptor_dtype (rhs_desc));
/* Assign the dimension as range-ref. */
tmp = gfc_get_descriptor_dimension (lhs_desc);
tmp2 = gfc_get_descriptor_dimension (rhs_desc);
lhs_dim = gfc_get_descriptor_dimension (lhs_desc);
rhs_dim = gfc_get_descriptor_dimension (rhs_desc);
type = lhs_type ? TREE_TYPE (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);
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);
/* The corank dimensions are not copied by the ARRAY_RANGE_REF. */
copy_coarray_desc_part (block, lhs_desc, rhs_desc);
}
/* Takes a derived type expression and returns the address of a temporary
@ -920,6 +965,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
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),

6
gcc/fortran/trans-intrinsic.cc
View File

@ -2073,9 +2073,13 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
GFC_STAT_STOPPED_IMAGE));
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
/* The team is optional and therefore needs to be a pointer to the opaque
pointer. */
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
args[0],
num_args < 2 ? null_pointer_node : args[1]);
num_args < 2
? null_pointer_node
: gfc_build_addr_expr (NULL_TREE, args[1]));
else
gcc_unreachable ();

7
gcc/fortran/trans-stmt.cc
View File

@ -1362,7 +1362,8 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
images = argse.expr;
images = gfc_trans_force_lval (&argse.pre, argse.expr);
gfc_add_block_to_block (&se.pre, &argse.pre);
}
if (code->expr2)
@ -1372,6 +1373,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
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;
@ -1384,8 +1386,9 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);
errmsg = argse.expr;
errmsglen = fold_convert (size_type_node, argse.string_length);
gfc_add_block_to_block (&se.pre, &argse.pre);
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
{

16
gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90
View File

@ -11,11 +11,19 @@ program main
end type
type(mytype), save :: object[*]
integer :: me
integer :: me, other
me=this_image()
allocate(object%indices(me))
object%indices = 42
other = me + 1
if (other .GT. num_images()) other = 1
if (me == num_images()) then
allocate(object%indices(me/2))
else
allocate(object%indices(me))
end if
object%indices = 42 * me
if ( any( object[me]%indices(:) /= 42 ) ) STOP 1
sync all
if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1
sync all
end program

25
gcc/testsuite/gfortran.dg/coarray/atomic_2.f90
View File

@ -61,7 +61,7 @@ end do
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12
if (stat /= 0 .or. var /= num_images() * 2) STOP 12
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 13
@ -328,7 +328,7 @@ end do
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45
if (stat /= 0 .or. var /= num_images() * 2) STOP 45
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 46
@ -403,7 +403,7 @@ if (this_image() < storage_size(caf)-2) then
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
if (stat /= 0 .or. var <= 0) STOP 53
if (stat /= 0) STOP 53
end do
end if
sync all
@ -544,7 +544,7 @@ if (this_image() < storage_size(caf)-2) then
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68
if (stat /= 0) STOP 68
end do
end if
sync all
@ -628,26 +628,27 @@ sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat)
if (stat /= 0 .or. var2 .neqv. .true.) STOP 82
if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82
call atomic_ref(var2, caf_log[num_images()], stat=stat)
if (stat /= 0 .or. var2 .neqv. .true.) STOP 83
if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83
end if
sync all
if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84
if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84
call atomic_ref(var2, caf_log[num_images()], stat=stat)
if (stat /= 0 .or. var2 .neqv. .true.) STOP 85
if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85
sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat)
if (stat /= 0 .or. var2 .neqv. .true.) STOP 86
if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86
call atomic_ref(var2, caf_log[num_images()], stat=stat)
if (stat /= 0 .or. var2 .neqv. .false.) STOP 87
if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87
end if
sync all
if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88
if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88
call atomic_ref(var2, caf_log[num_images()], stat=stat)
if (stat /= 0 .or. var2 .neqv. .false.) STOP 89
if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89
sync all
end

13
gcc/testsuite/gfortran.dg/coarray/caf.exp
View File

@ -70,6 +70,12 @@ proc dg-compile-aux-modules { args } {
}
}
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.
@ -103,6 +109,13 @@ foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]]
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

94
gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 Normal file
View File

@ -0,0 +1,94 @@
!{ 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

9
gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
View File

@ -19,7 +19,7 @@ program p
! For this reason, -fcoarray=single and -fcoarray=lib give the
! same result
if (allocated (a[1])) stop 3
if (allocated (c%x[1,2,3])) stop 4
if (allocated (c%x[1,1,1])) stop 4
! Allocate collectively
allocate(a[*])
@ -28,16 +28,17 @@ program p
if (.not. allocated (a)) stop 5
if (.not. allocated (c%x)) stop 6
if (.not. allocated (a[1])) stop 7
if (.not. allocated (c%x[1,2,3])) stop 8
if (.not. allocated (c%x[1,1,1])) stop 8
! Deallocate collectively
sync all
! Dellocate collectively
deallocate(a)
deallocate(c%x)
if (allocated (a)) stop 9
if (allocated (c%x)) stop 10
if (allocated (a[1])) stop 11
if (allocated (c%x[1,2,3])) stop 12
if (allocated (c%x[1,1,1])) stop 12
end
! Expected: always local access and never a call to _gfortran_caf_get

74
gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90
View File

@ -21,6 +21,7 @@ subroutine char_test()
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
@ -37,6 +38,7 @@ subroutine char_test()
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
@ -53,6 +55,7 @@ subroutine char_test()
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
@ -69,6 +72,7 @@ subroutine char_test()
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
@ -91,6 +95,7 @@ subroutine char_test()
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
@ -113,6 +118,7 @@ subroutine char_test()
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
@ -135,6 +141,7 @@ subroutine char_test()
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
@ -157,6 +164,7 @@ subroutine char_test()
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
@ -179,6 +187,7 @@ subroutine char_test()
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
@ -199,6 +208,7 @@ subroutine char_test()
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
@ -219,6 +229,7 @@ subroutine char_test()
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
@ -239,6 +250,7 @@ subroutine char_test()
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
@ -261,6 +273,7 @@ subroutine char_test()
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
@ -277,6 +290,7 @@ subroutine char_test()
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
@ -293,6 +307,7 @@ subroutine char_test()
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
@ -309,6 +324,7 @@ subroutine char_test()
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
@ -331,6 +347,7 @@ subroutine char_test()
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
@ -353,6 +370,7 @@ subroutine char_test()
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
@ -375,6 +393,7 @@ subroutine char_test()
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
@ -397,6 +416,7 @@ subroutine char_test()
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
@ -419,6 +439,7 @@ subroutine char_test()
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
@ -439,6 +460,7 @@ subroutine char_test()
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
@ -459,6 +481,7 @@ subroutine char_test()
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
@ -479,6 +502,7 @@ subroutine char_test()
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
@ -502,6 +526,7 @@ subroutine char_test()
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
@ -518,6 +543,7 @@ subroutine char_test()
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
@ -534,6 +560,7 @@ subroutine char_test()
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
@ -550,6 +577,7 @@ subroutine char_test()
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
@ -572,6 +600,7 @@ subroutine char_test()
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
@ -594,6 +623,7 @@ subroutine char_test()
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
@ -616,6 +646,7 @@ subroutine char_test()
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
@ -638,6 +669,7 @@ subroutine char_test()
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
@ -660,6 +692,7 @@ subroutine char_test()
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
@ -680,6 +713,7 @@ subroutine char_test()
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
@ -700,6 +734,7 @@ subroutine char_test()
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
@ -720,6 +755,7 @@ subroutine char_test()
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
@ -743,7 +779,8 @@ subroutine char_test()
str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
str1a = 1_"XXXXXXX"
str2a = 1_"XXXXXXX"
sync all
if (this_image() == num_images()) then
str2a[1] = ustr1a
end if
@ -760,6 +797,7 @@ subroutine char_test()
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
@ -776,6 +814,7 @@ subroutine char_test()
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
@ -792,6 +831,7 @@ subroutine char_test()
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
@ -814,6 +854,7 @@ subroutine char_test()
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
@ -836,6 +877,7 @@ subroutine char_test()
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
@ -858,6 +900,7 @@ subroutine char_test()
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
@ -880,6 +923,7 @@ subroutine char_test()
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
@ -902,6 +946,7 @@ subroutine char_test()
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
@ -922,6 +967,7 @@ subroutine char_test()
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
@ -942,6 +988,7 @@ subroutine char_test()
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
@ -962,6 +1009,7 @@ subroutine char_test()
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
@ -984,6 +1032,7 @@ subroutine char_test()
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
@ -1000,6 +1049,7 @@ subroutine char_test()
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
@ -1016,6 +1066,7 @@ subroutine char_test()
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
@ -1032,6 +1083,7 @@ subroutine char_test()
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
@ -1054,6 +1106,7 @@ subroutine char_test()
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
@ -1076,6 +1129,7 @@ subroutine char_test()
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
@ -1098,6 +1152,7 @@ subroutine char_test()
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
@ -1120,6 +1175,7 @@ subroutine char_test()
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
@ -1142,6 +1198,7 @@ subroutine char_test()
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
@ -1162,6 +1219,7 @@ subroutine char_test()
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
@ -1182,6 +1240,7 @@ subroutine char_test()
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
@ -1202,6 +1261,7 @@ subroutine char_test()
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
@ -1225,6 +1285,7 @@ subroutine char_test()
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
@ -1241,6 +1302,7 @@ subroutine char_test()
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
@ -1257,6 +1319,7 @@ subroutine char_test()
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
@ -1273,6 +1336,7 @@ subroutine char_test()
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
@ -1295,6 +1359,7 @@ subroutine char_test()
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
@ -1317,6 +1382,7 @@ subroutine char_test()
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
@ -1339,6 +1405,7 @@ subroutine char_test()
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
@ -1361,6 +1428,7 @@ subroutine char_test()
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
@ -1383,6 +1451,7 @@ subroutine char_test()
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
@ -1403,6 +1472,7 @@ subroutine char_test()
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
@ -1423,6 +1493,7 @@ subroutine char_test()
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
@ -1443,6 +1514,7 @@ subroutine char_test()
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

4
gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08
View File

@ -15,8 +15,8 @@ program pr98903
a = 42
s = 42
! Checking against single image only. Therefore team statements are
! not viable nor are they (yet) supported by GFortran.
sync all
if (a[1, team_number=-1, stat=s] /= 42) stop 1
if (s /= 0) stop 2

108
gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90
View File

@ -13,68 +13,72 @@ program coindexed_5
parentteam = get_team()
caf = [23, 32]
form team(t_num, team, new_index=1)
form team(t_num, team) !, new_index=num_images() - this_image() + 1)
form team(t_num, formed_team)
change team(team, cell[*] => caf(2))
! for get_from_remote
! Checking against caf_single is very limitted.
if (cell[1, team_number=t_num] /= 32) stop 1
if (cell[1, team_number=st_num] /= 32) stop 2
if (cell[1, team=parentteam] /= 32) stop 3
associate(me => this_image())
! for get_from_remote
! Checking against caf_single is very limitted.
if (cell[me, team_number=t_num] /= 32) stop 1
if (cell[me, team_number=st_num] /= 32) stop 2
if (cell[me, team=parentteam] /= 32) stop 3
! Check that team_number is validated
lhs = cell[1, team_number=5, stat=stat]
if (stat /= 1) stop 4
! Check that team_number is validated
lhs = cell[me, team_number=5, stat=stat]
if (stat /= 1) stop 4
! Check that only access to active teams is valid
stat = 42
lhs = cell[1, team=formed_team, stat=stat]
if (stat /= 1) stop 5
! Check that only access to active teams is valid
stat = 42
lhs = cell[me, team=formed_team, stat=stat]
if (stat /= 1) stop 5
! for send_to_remote
! Checking against caf_single is very limitted.
cell[1, team_number=t_num] = 45
if (cell /= 45) stop 11
cell[1, team_number=st_num] = 46
if (cell /= 46) stop 12
cell[1, team=parentteam] = 47
if (cell /= 47) stop 13
! for send_to_remote
! Checking against caf_single is very limitted.
cell[me, team_number=t_num] = 45
if (cell /= 45) stop 11
cell[me, team_number=st_num] = 46
if (cell /= 46) stop 12
cell[me, team=parentteam] = 47
if (cell /= 47) stop 13
! Check that team_number is validated
stat = -1
cell[1, team_number=5, stat=stat] = 0
if (stat /= 1) stop 14
! Check that team_number is validated
stat = -1
cell[me, team_number=5, stat=stat] = 0
if (stat /= 1) stop 14
! Check that only access to active teams is valid
stat = 42
cell[1, team=formed_team, stat=stat] = -1
if (stat /= 1) stop 15
! Check that only access to active teams is valid
stat = 42
cell[me, team=formed_team, stat=stat] = -1
if (stat /= 1) stop 15
! for transfer_between_remotes
! Checking against caf_single is very limitted.
cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
if (cell /= 23) stop 21
cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
! cell is an alias for caf(2) and has been overwritten by caf(1)!
if (cell /= 23) stop 22
cell[1, team=parentteam] = caf(1)[1, team= team]
if (cell /= 23) stop 23
! for transfer_between_remotes
! Checking against caf_single is very limitted.
cell[me, team_number=t_num] = caf(1)[me, team_number=-1]
if (cell /= 23) stop 21
cell[me, team_number=st_num] = caf(2)[me, team_number=-1]
! cell is an alias for caf(2) and has been overwritten by caf(1)!
if (cell /= 23) stop 22
cell[me, team=parentteam] = caf(1)[me, team= team]
if (cell /= 23) stop 23
! Check that team_number is validated
stat = -1
cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
if (stat /= 1) stop 24
stat = -1
cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
if (stat /= 1) stop 25
! Check that team_number is validated
stat = -1
cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1]
if (stat /= 1) stop 24
stat = -1
cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat]
if (stat /= 1) stop 25
! Check that only access to active teams is valid
stat = 42
cell[1, team=formed_team, stat=stat] = caf(1)[1]
if (stat /= 1) stop 26
stat = 42
cell[1] = caf(1)[1, team=formed_team, stat=stat]
if (stat /= 1) stop 27
! Check that only access to active teams is valid
stat = 42
cell[me, team=formed_team, stat=stat] = caf(1)[me]
if (stat /= 1) stop 26
stat = 42
cell[me] = caf(1)[me, team=formed_team, stat=stat]
if (stat /= 1) stop 27
sync all
end associate
end team
end program coindexed_5

1
gcc/testsuite/gfortran.dg/coarray/dummy_3.f90
View File

@ -15,6 +15,7 @@ program pr77871
p%i = 42
allocate (p2(5)[*])
p2(:)%i = (/(i, i=0, 4)/)
sync all
call s(p, 1)
call s2(p2, 1)
contains

75
gcc/testsuite/gfortran.dg/coarray/event_1.f90
View File

@ -5,47 +5,54 @@
use iso_fortran_env, only: event_type
implicit none
type(event_type), save :: var[*]
type(event_type), save, allocatable, dimension(:) :: events[:]
integer :: count, stat
count = -42
call event_query (var, count)
if (count /= 0) STOP 1
associate (me => this_image(), np => num_images())
allocate(events(np)[*])
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
associate(var => events(me))
count = -42
call event_query (var, count)
if (count /= 0) STOP 1
stat = 99
event post (var[this_image()])
call event_query(var, count)
if (count /= 2) STOP 4
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 wait (var)
call event_query(var, count)
if (count /= 1) STOP 5
count = 99
event post (var[this_image()])
call event_query(var, count)
if (count /= 2) STOP 4
stat = 99
event post (var)
call event_query(var, count)
if (count /= 2) STOP 6
count = 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 /= 3) STOP 7
count = 99
event post (var)
call event_query(var, count)
if (count /= 2) STOP 6
stat = 99
event wait (var, until_count=2)
call event_query(var, count)
if (count /= 1) STOP 8
count = 99
event post (var)
call event_query(var, count)
if (count /= 3) STOP 7
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
count = 99
event wait (var, until_count=2)
call event_query(var, count)
if (count /= 1) STOP 8
stat = 99
event wait (var, stat=stat, until_count=1)
if (stat /= 0) STOP 9
count = 99
call event_query(event=var, stat=stat, count=count)
if (count /= 0 .or. stat /= 0) STOP 10
end associate
end associate
end

4
gcc/testsuite/gfortran.dg/coarray/event_3.f08
View File

@ -11,8 +11,8 @@ program global_event
contains
subroutine exchange
integer :: cnt
event post(x[1])
event post(x[1])
event post(x[this_image()])
event post(x[this_image()])
call event_query(x, cnt)
if (cnt /= 2) error stop 1
event wait(x, until_count=2)

3
gcc/testsuite/gfortran.dg/coarray/event_4.f08
View File

@ -8,5 +8,6 @@ program event_4
type(event_type) done[*]
nc(1) = 1
event post(done[1])
event wait(done,until_count=nc(1))
if (this_image() == 1) event wait(done,until_count=nc(1))
sync all
end

2
gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08
View File

@ -8,7 +8,7 @@ program test_failed_images_1
integer :: i
fi = failed_images() ! OK
fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" }
fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
fi = failed_images(KIND=1) ! OK
fi = failed_images(KIND=4) ! OK
fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" }

39
gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08
View File

@ -1,17 +1,44 @@
! { dg-do run }
program test_failed_images_2
use iso_fortran_env
implicit none
type(team_type) :: t
integer, allocatable :: fi(:)
integer(kind=1), allocatable :: sfi(:)
integer, allocatable :: rem_images(:)
integer :: i, st
fi = failed_images()
if (size(fi) > 0) error stop "failed_images result shall be empty array"
sfi = failed_images(KIND=1)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
sfi = failed_images(KIND=8)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
associate(np => num_images())
form team (1, t)
fi = failed_images()
if (size(fi) > 0) stop 1
sfi = failed_images(KIND=1)
if (size(sfi) > 0) stop 2
sfi = failed_images(KIND=8)
if (size(sfi) > 0) stop 3
fi = failed_images(t)
if (size(fi) > 0) stop 4
if (num_images() > 1) then
sync all
if (this_image() == 2) fail image
rem_images = (/ 1, ( i, i = 3, np )/)
! Can't synchronize well on a failed image. Try with a sleep.
do i = 0, 10
if (size(failed_images()) == 0) then
call sleep(1)
else
exit
end if
end do
if (i == 10 .AND. size(failed_images()) == 0) stop 5
sync images (rem_images, stat=st)
if (any(failed_images() /= [2])) stop 6
if (any(failed_images(t, 8) /= [2])) stop 7
end if
end associate
end program test_failed_images_2

2
gcc/testsuite/gfortran.dg/coarray/image_status_1.f08
View File

@ -18,7 +18,7 @@ program test_image_status_1
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" }
isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }

32
gcc/testsuite/gfortran.dg/coarray/image_status_2.f08
View File

@ -1,12 +1,38 @@
! { dg-do run }
program test_image_status_2
use iso_fortran_env , only : STAT_STOPPED_IMAGE
use iso_fortran_env
implicit none
type(team_type) :: t
integer :: i, st
integer, allocatable :: rem_images(:)
form team (1, t)
if (image_status(1) /= 0) error stop "Image 1 should report OK."
if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped."
if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped."
if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK."
if (num_images() > 1) then
associate (np => num_images())
sync all
if (this_image() == 2) fail image
rem_images = (/ 1, ( i, i = 3, np )/)
! Can't synchronize well on failed image. Try with a sleep.
do i = 0, 10
if (image_status(2) /= STAT_FAILED_IMAGE) then
call sleep(1)
else
exit
end if
end do
sync images (rem_images, stat=st)
if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
end associate
end if
end program test_image_status_2

2
gcc/testsuite/gfortran.dg/coarray/lock_2.f90
View File

@ -58,6 +58,8 @@ if (stat /= 0) STOP 9
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)

8
gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90
View File

@ -12,28 +12,28 @@ allocate(a(1)[*])
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 1
if (any (lcobound(a) /= 1)) STOP 2
if (any (ucobound(a) /= this_image())) STOP 3
if (any (ucobound(a) /= num_images())) STOP 3
deallocate(a)
allocate(b[*])
if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
STOP 4
if (any (lcobound(b) /= 1)) STOP 5
if (any (ucobound(b) /= this_image())) STOP 6
if (any (ucobound(b) /= num_images())) STOP 6
deallocate(b)
allocate(a(1)[-10:*])
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 7
if (any (lcobound(a) /= -10)) STOP 8
if (any (ucobound(a) /= -11+this_image())) STOP 9
if (any (ucobound(a) /= -11 + num_images())) STOP 9
deallocate(a)
allocate(d[23:*])
if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
STOP 10
if (any (lcobound(d) /= 23)) STOP 11
if (any (ucobound(d) /= 22+this_image())) STOP 12
if (any (ucobound(d) /= 22 + num_images())) STOP 12
deallocate(d)
end

13
gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90
View File

@ -19,7 +19,7 @@ if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) &
deallocate(a)
allocate(a[4:*])
a[this_image ()] = 8 - 2*this_image ()
a[this_image () + 3] = 8 - 2*this_image ()
if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
STOP 4
@ -30,6 +30,7 @@ n3 = 3
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
@ -47,7 +48,8 @@ contains
STOP 8
if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
STOP 9
if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10
sync all
deallocate(x)
end subroutine sub
@ -56,12 +58,13 @@ contains
integer, allocatable, SAVE :: a[:]
if (init) then
if (allocated(a)) STOP 10
if (allocated(a)) STOP 11
allocate(a[*])
a = 45
else
if (.not. allocated(a)) STOP 11
if (a /= 45) STOP 12
if (.not. allocated(a)) STOP 12
if (a /= 45) STOP 13
sync all
deallocate(a)
end if
end subroutine two

2
gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08
View File

@ -8,7 +8,7 @@ program test_stopped_images_1
integer :: i
gi = stopped_images() ! OK
gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" }
gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" }
gi = stopped_images(KIND=1) ! OK
gi = stopped_images(KIND=4) ! OK
gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" }

39
gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08
View File

@ -1,17 +1,44 @@
! { dg-do run }
program test_stopped_images_2
use iso_fortran_env
implicit none
type(team_type) :: t
integer, allocatable :: si(:)
integer(kind=1), allocatable :: ssi(:)
integer, allocatable :: rem_images(:)
integer :: i, st
si = stopped_images()
if (size(si) > 0) error stop "stopped_images result shall be empty array"
ssi = stopped_images(KIND=1)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
ssi = stopped_images(KIND=8)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
associate(np => num_images())
form team (1, t)
si = stopped_images()
if (size(si) > 0) stop 1
ssi = stopped_images(KIND=1)
if (size(ssi) > 0) stop 2
ssi = stopped_images(KIND=8)
if (size(ssi) > 0) stop 3
si = stopped_images(t)
if (size(si) > 0) stop 4
if (num_images() > 1) then
sync all
if (this_image() == 2) stop
rem_images = (/ 1, ( i, i = 3, np )/)
! Can't synchronize well on a stopped image. Try with a sleep.
do i = 0, 10
if (size(stopped_images()) == 0) then
call sleep(1)
else
exit
end if
end do
if (i == 10 .AND. size(stopped_images()) == 0) stop 5
sync images (rem_images, stat=st)
if (any(stopped_images() /= [2])) stop 6
if (any(stopped_images(t, 8) /= [2])) stop 7
end if
end associate
end program test_stopped_images_2

8
gcc/testsuite/gfortran.dg/coarray/sync_1.f90
View File

@ -26,7 +26,6 @@ n = 5
sync all (stat=n,errmsg=str)
if (n /= 0) STOP 2
!
! Test SYNC MEMORY
!
@ -42,17 +41,21 @@ n = 5
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
@ -61,4 +64,5 @@ n = 5
sync images (*,errmsg=str,stat=n)
if (n /= 0) STOP 6
sync all
end

26
gcc/testsuite/gfortran.dg/coarray/sync_3.f90
View File

@ -9,8 +9,9 @@
! PR fortran/18918
implicit none
integer :: n
character(len=30) :: str
integer :: n, st
integer,allocatable :: others(:)
character(len=40) :: str
critical
end critical
myCr: critical
@ -58,17 +59,32 @@ if (this_image() == 1) then
sync images ([1])
end if
! Need to sync all here, because otherwise sync image 1 may overlap with the
! sync images(*, stat=n) below and that may hang for num_images() > 1.
sync all
n = 5
sync images (*, stat=n)
if (n /= 0) STOP 5
n = 5
sync images (*,errmsg=str,stat=n)
sync images (*, errmsg=str, stat=n)
if (n /= 0) STOP 6
if (this_image() == num_images()) then
others = (/( n, n=1, (num_images() - 1)) /)
sync images(others)
else
sync images ( num_images() )
end if
n = -1
sync images ( num_images() )
sync images (n) ! Invalid: "-1"
st = 0
sync images (n, errmsg=str, stat=st)
if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7
! Do this only on image 1, or output of error messages will clutter
if (this_image() == 1) sync images (n) ! Invalid: "-1"
end

33
gcc/testsuite/gfortran.dg/coarray/sync_team.f90 Normal file
View File

@ -0,0 +1,33 @@
!{ 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

4
gcc/testsuite/gfortran.dg/coarray_sync_memory.f90
View File

@ -14,5 +14,5 @@ end
! { 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" } }

23
libgfortran/Makefile.am
View File

@ -58,13 +58,30 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version`
$(version_arg) -Wc,-shared-libgcc
libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
cafexeclib_LTLIBRARIES = libcaf_single.la
libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
libcaf_shared_SRCS = caf/caf_error.c
cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
libcaf_single_la_SOURCES = caf/single.c
libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
libcaf_single_la_LDFLAGS = -static
libcaf_single_la_DEPENDENCIES = caf/libcaf.h
libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
libcaf_shmem_la_LDFLAGS = -static
libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
if IEEE_SUPPORT
fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod

133
libgfortran/Makefile.in
View File

@ -217,21 +217,31 @@ am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \
"$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \
"$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)"
LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
libcaf_single_la_LIBADD =
libcaf_shmem_la_LIBADD =
am__dirstamp = $(am__leading_dot)dirstamp
am_libcaf_single_la_OBJECTS = caf/single.lo
am__objects_1 = caf/caf_error.lo
am_libcaf_shmem_la_OBJECTS = $(am__objects_1) caf/shmem.lo \
caf/shmem/alloc.lo caf/shmem/allocator.lo \
caf/shmem/collective_subroutine.lo \
caf/shmem/counter_barrier.lo caf/shmem/hashmap.lo \
caf/shmem/shared_memory.lo caf/shmem/supervisor.lo \
caf/shmem/sync.lo caf/shmem/teams_mgmt.lo \
caf/shmem/thread_support.lo
libcaf_shmem_la_OBJECTS = $(am_libcaf_shmem_la_OBJECTS)
libcaf_single_la_LIBADD =
am_libcaf_single_la_OBJECTS = caf/single.lo $(am__objects_1)
libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS)
libgfortran_la_LIBADD =
@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo
@LIBGFOR_MINIMAL_FALSE@am__objects_2 = runtime/backtrace.lo \
@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo
@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/convert_char.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/environ.lo runtime/error.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/fpu.lo runtime/main.lo \
@LIBGFOR_MINIMAL_FALSE@ runtime/pause.lo runtime/stop.lo
am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \
am__objects_4 = runtime/bounds.lo runtime/compile_options.lo \
runtime/memory.lo runtime/string.lo runtime/select.lo \
$(am__objects_1) $(am__objects_2)
am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
$(am__objects_2) $(am__objects_3)
am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \
generated/matmul_i4.lo generated/matmul_i8.lo \
generated/matmul_i16.lo generated/matmul_r4.lo \
generated/matmul_r8.lo generated/matmul_r10.lo \
@ -239,9 +249,9 @@ am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \
generated/matmul_c4.lo generated/matmul_c8.lo \
generated/matmul_c10.lo generated/matmul_c16.lo \
generated/matmul_c17.lo
am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \
am__objects_6 = generated/matmul_l4.lo generated/matmul_l8.lo \
generated/matmul_l16.lo
am__objects_6 = generated/matmulavx128_i1.lo \
am__objects_7 = generated/matmulavx128_i1.lo \
generated/matmulavx128_i2.lo generated/matmulavx128_i4.lo \
generated/matmulavx128_i8.lo generated/matmulavx128_i16.lo \
generated/matmulavx128_r4.lo generated/matmulavx128_r8.lo \
@ -249,7 +259,7 @@ am__objects_6 = generated/matmulavx128_i1.lo \
generated/matmulavx128_r17.lo generated/matmulavx128_c4.lo \
generated/matmulavx128_c8.lo generated/matmulavx128_c10.lo \
generated/matmulavx128_c16.lo generated/matmulavx128_c17.lo
am__objects_7 = generated/all_l1.lo generated/all_l2.lo \
am__objects_8 = generated/all_l1.lo generated/all_l2.lo \
generated/all_l4.lo generated/all_l8.lo generated/all_l16.lo \
generated/any_l1.lo generated/any_l2.lo generated/any_l4.lo \
generated/any_l8.lo generated/any_l16.lo \
@ -538,17 +548,17 @@ am__objects_7 = generated/all_l1.lo generated/all_l2.lo \
generated/pow_m8_m16.lo generated/pow_m16_m1.lo \
generated/pow_m16_m2.lo generated/pow_m16_m4.lo \
generated/pow_m16_m8.lo generated/pow_m16_m16.lo \
$(am__objects_4) $(am__objects_5) $(am__objects_6) \
$(am__objects_5) $(am__objects_6) $(am__objects_7) \
runtime/ISO_Fortran_binding.lo
@LIBGFOR_MINIMAL_FALSE@am__objects_8 = io/close.lo io/file_pos.lo \
@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \
@LIBGFOR_MINIMAL_FALSE@ io/format.lo io/inquire.lo \
@LIBGFOR_MINIMAL_FALSE@ io/intrinsics.lo io/list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ io/lock.lo io/open.lo io/read.lo \
@LIBGFOR_MINIMAL_FALSE@ io/transfer.lo io/transfer128.lo \
@LIBGFOR_MINIMAL_FALSE@ io/unit.lo io/unix.lo io/write.lo \
@LIBGFOR_MINIMAL_FALSE@ io/fbuf.lo io/async.lo
am__objects_9 = io/size_from_kind.lo $(am__objects_8)
@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \
am__objects_10 = io/size_from_kind.lo $(am__objects_9)
@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/chdir.lo intrinsics/chmod.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/clock.lo \
@ -572,8 +582,8 @@ am__objects_9 = io/size_from_kind.lo $(am__objects_8)
@LIBGFOR_MINIMAL_FALSE@ intrinsics/system_clock.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/time.lo intrinsics/umask.lo \
@LIBGFOR_MINIMAL_FALSE@ intrinsics/unlink.lo
@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo
am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.lo
am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \
intrinsics/args.lo intrinsics/cshift0.lo \
intrinsics/eoshift0.lo intrinsics/eoshift2.lo \
intrinsics/erfc_scaled.lo intrinsics/extends_type_of.lo \
@ -588,12 +598,12 @@ am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \
intrinsics/selected_real_kind.lo intrinsics/trigd.lo \
intrinsics/unpack_generic.lo runtime/in_pack_generic.lo \
runtime/in_unpack_generic.lo runtime/in_pack_class.lo \
runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11)
@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \
runtime/in_unpack_class.lo $(am__objects_11) $(am__objects_12)
@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \
@IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo
am__objects_14 =
am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \
am__objects_15 =
am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \
generated/_abs_c10.lo generated/_abs_c16.lo \
generated/_abs_c17.lo generated/_abs_i4.lo \
generated/_abs_i8.lo generated/_abs_i16.lo \
@ -679,9 +689,9 @@ am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \
generated/_mod_r17.lo generated/misc_specifics.lo \
intrinsics/dprod_r8.lo intrinsics/f2c_specifics.lo \
intrinsics/random_init.lo
am_libgfortran_la_OBJECTS = $(am__objects_3) $(am__objects_7) \
$(am__objects_9) $(am__objects_12) $(am__objects_13) \
$(am__objects_14) $(am__objects_15)
am_libgfortran_la_OBJECTS = $(am__objects_4) $(am__objects_8) \
$(am__objects_10) $(am__objects_13) $(am__objects_14) \
$(am__objects_15) $(am__objects_16)
libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS)
AM_V_P = $(am__v_P_@AM_V@)
am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
@ -746,7 +756,8 @@ AM_V_FC = $(am__v_FC_@AM_V@)
am__v_FC_ = $(am__v_FC_@AM_DEFAULT_V@)
am__v_FC_0 = @echo " FC " $@;
am__v_FC_1 =
SOURCES = $(libcaf_single_la_SOURCES) $(libgfortran_la_SOURCES)
SOURCES = $(libcaf_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \
$(libgfortran_la_SOURCES)
am__can_run_installinfo = \
case $$AM_UPDATE_INFO_DIR in \
n|no|NO) false;; \
@ -962,12 +973,28 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version`
$(version_arg) -Wc,-shared-libgcc
libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP)
cafexeclib_LTLIBRARIES = libcaf_single.la
libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h
libcaf_shared_SRCS = caf/caf_error.c
cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la
cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)
libcaf_single_la_SOURCES = caf/single.c
libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS)
libcaf_single_la_LDFLAGS = -static
libcaf_single_la_DEPENDENCIES = caf/libcaf.h
libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS)
libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS)
libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \
caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \
caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \
caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \
caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c
libcaf_shmem_la_LDFLAGS = -static
libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \
caf/shmem/allocator.h caf/shmem/collective_subroutine.h \
caf/shmem/counter_barrier.h caf/shmem/hashmap.h \
caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \
caf/shmem/teams_mgmt.h caf/shmem/thread_support.h
libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS)
@IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude
@IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
@ -1964,6 +1991,37 @@ caf/$(am__dirstamp):
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)
@ -3771,6 +3829,8 @@ mostlyclean-compile:
-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)
@ -3785,7 +3845,19 @@ mostlyclean-compile:
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@
@ -4550,6 +4622,7 @@ mostlyclean-libtool:
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
@ -4717,6 +4790,8 @@ distclean-generic:
-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)
@ -4739,7 +4814,7 @@ clean-am: clean-cafexeclibLTLIBRARIES clean-generic clean-libtool \
distclean: distclean-am
-rm -f $(am__CONFIG_DISTCLEAN_FILES)
-rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -f Makefile
distclean-am: clean-am distclean-compile distclean-generic \
distclean-hdr distclean-libtool distclean-local distclean-tags
@ -4788,7 +4863,7 @@ installcheck-am:
maintainer-clean: maintainer-clean-am
-rm -f $(am__CONFIG_DISTCLEAN_FILES)
-rm -rf $(top_srcdir)/autom4te.cache
-rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR)
-rm -f Makefile
maintainer-clean-am: distclean-am maintainer-clean-generic \
maintainer-clean-local

12
libgfortran/acinclude.m4
View File

@ -578,3 +578,15 @@ main ()
[Define to 1 if you have the `$1' function.])
fi
])
AC_DEFUN([LIBGFOR_CHECK_SANE_BUILTIN_CLZL], [
AC_RUN_IFELSE([AC_LANG_PROGRAM([[
int main()
{
return __builtin_clzl(256) != 8;
}]], [[]])],
AC_DEFINE(HAVE_SANE_BUILTIN_CLZL, 1,
[Define if __builtin_clzl behaves as expected.])
AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],true),
[AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],false)])
])

71
libgfortran/caf/caf_error.c Normal file
View File

@ -0,0 +1,71 @@
/* 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);
}

44
libgfortran/caf/caf_error.h Normal file
View File

@ -0,0 +1,44 @@
/* 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

12
libgfortran/caf/libcaf.h
View File

@ -26,9 +26,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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
@ -175,12 +172,9 @@ void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, size_t);
void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, size_t);
void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
void _gfortran_caf_failed_images (gfc_descriptor_t *,
caf_team_t * __attribute__ ((unused)), int *);
int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused)));
void _gfortran_caf_stopped_images (gfc_descriptor_t *,
caf_team_t * __attribute__ ((unused)),
int *);
void _gfortran_caf_failed_images (gfc_descriptor_t *, caf_team_t *, int *);
int _gfortran_caf_image_status (int, caf_team_t *);
void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *);
void _gfortran_caf_random_init (bool, bool);

1906
libgfortran/caf/shmem.c Normal file
View File

File diff suppressed because it is too large Load Diff

168
libgfortran/caf/shmem/alloc.c Normal file
View File

@ -0,0 +1,168 @@
/* 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 "thread_support.h"
#include <assert.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;
}

80
libgfortran/caf/shmem/alloc.h Normal file
View File

@ -0,0 +1,80 @@
/* 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

145
libgfortran/caf/shmem/allocator.c Normal file
View File

@ -0,0 +1,145 @@
/* 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. */
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#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)
{
#ifdef HAVE_SANE_BUILTIN_CLZL
assert (size);
#if (__INTPTR_WIDTH__ == 64)
return 1 << (VOIDP_BITS - __builtin_clzl (size - 1));
#else
return 1 << (VOIDP_BITS - __builtin_clz (size - 1));
#endif
#else
return 1 << (int)ceil(log2(size));
#endif
}
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);
assert (bucket_list_index
< (int) (sizeof (a->s->free_bucket_head) / sizeof (shared_mem_ptr)));
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)
{
caf_shmem_mutex_lock (&a->s->lock);
}
void
allocator_unlock (allocator *a)
{
caf_shmem_mutex_unlock (&a->s->lock);
}

88
libgfortran/caf/shmem/allocator.h Normal file
View File

@ -0,0 +1,88 @@
/* 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 "thread_support.h"
#include <stddef.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 {
caf_shmem_mutex 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

434
libgfortran/caf/shmem/collective_subroutine.c Normal file
View File

@ -0,0 +1,434 @@
/* 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;
caf_shmem_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);
caf_shmem_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 ();
}

50
libgfortran/caf/shmem/collective_subroutine.h Normal file
View File

@ -0,0 +1,50 @@
/* 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;
caf_shmem_mutex 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

127
libgfortran/caf/shmem/counter_barrier.c Normal file
View File

@ -0,0 +1,127 @@
/* 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)
{
caf_shmem_mutex_lock (&b->mutex);
}
/* Unlock the associated counter of this barrier. */
static inline void
unlock_counter_barrier (counter_barrier *b)
{
caf_shmem_mutex_unlock (&b->mutex);
}
void
counter_barrier_init (counter_barrier *b, int val)
{
*b = (counter_barrier) {CAF_SHMEM_MUTEX_INITIALIZER,
CAF_SHMEM_COND_INITIALIZER, val, 0, val};
initialize_shared_condition (&b->cond, val);
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)
caf_shmem_cond_broadcast (&b->cond);
else
{
while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)
caf_shmem_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)
caf_shmem_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;
caf_shmem_mutex_lock (&c->mutex);
ret = counter_barrier_add_locked (c, val);
caf_shmem_mutex_unlock (&c->mutex);
return ret;
}
void
counter_barrier_init_add (counter_barrier *b, int val)
{
b->count += val;
b->wait_count += val;
caf_shmem_cond_update_count (&b->cond, val);
}
int
counter_barrier_get_count (counter_barrier *c)
{
int ret;
caf_shmem_mutex_lock (&c->mutex);
ret = c->count;
caf_shmem_mutex_unlock (&c->mutex);
return ret;
}

80
libgfortran/caf/shmem/counter_barrier.h Normal file
View File

@ -0,0 +1,80 @@
/* 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 "thread_support.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
{
caf_shmem_mutex mutex;
caf_shmem_condvar 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);
/* Add the given number to the counter barrier. This version does not signal.
The mutex needs to be locked for this routine to be safe. */
void counter_barrier_init_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

366
libgfortran/caf/shmem/hashmap.c Normal file
View File

@ -0,0 +1,366 @@
/* 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);
}

98
libgfortran/caf/shmem/hashmap.h Normal file
View File

@ -0,0 +1,98 @@
/* 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

292
libgfortran/caf/shmem/shared_memory.c Normal file
View File

@ -0,0 +1,292 @@
/* 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/>. */
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "libgfortran.h"
#include "allocator.h"
#include "shared_memory.h"
#include "supervisor.h"
#include <assert.h>
#include <fcntl.h>
#include <stdlib.h>
#include <string.h>
#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
#elif defined(WIN32)
#include <Windows.h>
#include <Memoryapi.h>
#endif
#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);
#ifdef HAVE_SETENV
setenv (ENV_PPID, buffer, 1);
#else
SetEnvironmentVariable (ENV_PPID, buffer);
#endif
#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 ();
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)
{
#ifdef HAVE_MMAP
int res;
mem->shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);
if (mem->shm_fd == -1)
{
perror ("creating shared memory segment failed.");
exit (1);
}
res = ftruncate (mem->shm_fd, size);
if (res == -1)
{
perror ("resizing shared memory segment failed.");
exit (1);
}
#elif defined(WIN32)
mem->shm_fd
= CreateFileMapping (INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE,
size >> (sizeof (DWORD) * 8),
(DWORD) (size & ~((DWORD) 0)), shm_name);
if (mem->shm_fd == NULL)
{
LPVOID lpMsgBuf;
DWORD dw = GetLastError ();
if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
| FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, dw,
MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &lpMsgBuf, 0, NULL)
== 0)
{
fprintf (stderr, "formatting the error message failed.\n");
ExitProcess (dw);
}
fprintf (stderr, "creating shared memory segment failed: %d, %s\n",
dw, (LPCTSTR) lpMsgBuf);
LocalFree (lpMsgBuf);
exit (1);
}
#else
#error "no way to map shared memory."
#endif
}
else
{
#ifdef HAVE_MMAP
mem->shm_fd = shm_open (shm_name, O_RDWR, 0600);
if (mem->shm_fd == -1)
{
perror ("opening shared memory segment failed.");
exit (1);
}
#elif defined(WIN32)
mem->shm_fd = OpenFileMapping (FILE_MAP_ALL_ACCESS, FALSE, shm_name);
if (mem->shm_fd == NULL)
{
perror ("opening shared memory segment failed.");
exit (1);
}
#endif
}
#ifdef HAVE_MMAP
mem->glbl.base
= mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0);
if (base_ptr && mem->glbl.base != base_ptr)
{
/* The supervisor will start us again. */
close (mem->shm_fd);
free (local);
exit (210);
}
else if (!base_ptr && !mem->glbl.base)
{
perror ("mmap failed");
exit (1);
}
#elif defined(WIN32)
mem->glbl.base
= (LPTSTR) MapViewOfFileExNuma (mem->shm_fd, FILE_MAP_ALL_ACCESS, 0, 0,
size, base_ptr, NUMA_NO_PREFERRED_NODE);
if (mem->glbl.base == NULL)
{
perror ("MapViewOfFile failed");
exit (1);
}
#endif
if (!base_ptr)
{
#define bufsize 20
char buffer[bufsize];
snprintf (buffer, bufsize, "%p", mem->glbl.base);
#ifdef HAVE_SETENV
setenv (ENV_BASE, buffer, 1);
#else
SetEnvironmentVariable (ENV_BASE, buffer);
#endif
#undef bufsize
}
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 *mem)
{
#ifdef HAVE_MMAP
int res = munmap (mem->glbl.base, mem->size);
if (res)
{
perror ("unmapping shared memory segment failed");
}
res = close (mem->shm_fd);
if (res)
{
perror ("closing shm file handle failed. Trying to continue...");
}
if (this_image.image_num == -1)
{
char shm_name[NAME_MAX];
snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ());
/* Only the supervisor is to delete the shm-file. */
res = shm_unlink (shm_name);
if (res == -1)
{
perror ("shm_unlink failed");
exit (1);
}
}
#elif defined(WIN32)
if (!UnmapViewOfFile (mem->glbl.base))
{
perror ("unmapping shared memory segment failed");
}
CloseHandle (mem->shm_fd);
#endif
}
#undef NAME_MAX

96
libgfortran/caf/shmem/shared_memory.h Normal file
View File

@ -0,0 +1,96 @@
/* 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 "thread_support.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
caf_shmem_fd shm_fd;
} 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

550
libgfortran/caf/shmem/supervisor.c Normal file
View File

@ -0,0 +1,550 @@
/* 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 "supervisor.h"
#include "teams_mgmt.h"
#include "thread_support.h"
#include <assert.h>
#include <signal.h>
#include <string.h>
#include <unistd.h>
#ifdef HAVE_WAIT_H
#include <wait.h>
#elif HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
#if !defined(_SC_PAGE_SIZE) && defined(WIN32)
#include <windows.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"
#define GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS "GFORTRAN_IMAGE_RESTARTS_LIMIT"
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)
#ifdef _SC_NPROCESSORS_ONLN
return sysconf (_SC_NPROCESSORS_ONLN);
#elif defined(WIN32)
num_images_char = getenv ("NUMBER_OF_PROCESSORS");
#else
#error "Unsupported system: No known way to get number of cores!"
#endif
nimages = atoi (num_images_char);
return nimages;
}
/* Get the number of restarts allowed when the shared memory could not be placed
at the same location in each image. This is mostly important for MacOS, because
this OS acts somewhat arbitrary/indeterministic. */
static unsigned
get_image_restarts_limit (void)
{
char *limit_chars;
unsigned limit = 4000;
limit_chars = getenv (GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS);
if (limit_chars)
limit = atoi (limit_chars);
return limit;
}
/* 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
#ifndef WIN32
sz = ((size_t) 1) << 34;
#else
/* Use 1GB on Windows. */
sz = ((size_t) 1) << 30;
#endif
}
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));
if (!local)
{
caf_runtime_error ("can not initialize memory for local cache");
exit (1);
}
#if defined(_SC_PAGE_SIZE)
pagesize = sysconf (_SC_PAGE_SIZE);
#elif defined(WIN32)
{
SYSTEM_INFO si;
GetNativeSystemInfo (&si);
pagesize = si.dwAllocationGranularity;
}
#else
#warning \
"Unsupported system: No known way to get memory page size. Assuming 4k!"
pagesize = 4096;
#endif
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;
thread_support_init_supervisor ();
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);
}
}
#if !defined(environ)
extern char **environ;
#endif
static bool
startWorker (image *im __attribute__ ((unused)),
char ***argv __attribute__ ((unused)))
{
#ifdef HAVE_FORK
caf_shmem_pid new_pid;
if ((new_pid = fork ()))
{
im->supervisor->images[im->image_num]
= (image_tracker) {new_pid, IMAGE_OK};
return false;
}
else
{
if (new_pid == -1)
caf_runtime_error ("error spawning child\n");
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;
if (execve ((*argv)[0], *argv, new_env) == -1)
{
perror ("execve failed");
}
exit (255);
}
#endif
return true;
}
#ifndef WIN32
static void
kill_all_images (supervisor *m)
{
for (int j = 0; j < local->total_num_images; j++)
if (m->images[j].status == IMAGE_OK)
kill (m->images[j].pid, SIGKILL);
}
#endif
/* argc and argv may not be used on certain OSes. Flag them unused therefore.
*/
int
supervisor_main_loop (int *argc __attribute__ ((unused)),
char ***argv __attribute__ ((unused)), int *exit_code)
{
supervisor *m;
image im;
#if defined(WIN32) && !defined(HAVE_FORK)
HANDLE *process_handles = malloc (sizeof (HANDLE) * local->total_num_images),
*thread_handles = malloc (sizeof (HANDLE) * local->total_num_images),
*waiting_handles = malloc (sizeof (HANDLE) * local->total_num_images);
int count_waiting = local->total_num_images;
LPTCH *envs = malloc (sizeof (LPTCH) * local->total_num_images);
LPTSTR currentDir;
DWORD cdLen = GetCurrentDirectory (0, NULL);
currentDir = malloc (cdLen);
GetCurrentDirectory (cdLen, currentDir);
#else
int chstatus;
unsigned restarts = 0, restarts_limit;
restarts_limit = get_image_restarts_limit ();
#endif
*exit_code = 0;
shared_memory_set_env (getpid ());
im.supervisor = m = this_image.supervisor;
for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)
{
#ifdef HAVE_FORK
if (startWorker (&im, argv))
return 1;
#elif defined(WIN32)
LPTCH new_env;
size_t n = 0, es;
STARTUPINFO si;
DWORD dwFlags = 0;
PROCESS_INFORMATION pi;
LPTCH env = GetEnvironmentStrings ();
ZeroMemory (&si, sizeof (si));
si.cb = sizeof (si);
ZeroMemory (&pi, sizeof (pi));
/* Count the number of characters in the current environment. */
for (LPTSTR e = (LPTSTR) env; *e; es = lstrlen (e) + 1, e += es, n += es)
;
new_env = (LPCH) malloc (n + 32 * sizeof (TCHAR));
memcpy (new_env, env, n);
snprintf (&((TCHAR *) new_env)[n], 32, "%s=%d%c", GFORTRAN_ENV_IMAGE_NUM,
im.image_num, (char) 0);
if (!CreateProcessA (NULL, GetCommandLine (), NULL, NULL, FALSE, dwFlags,
new_env, currentDir, &si, &pi))
{
LPVOID lpMsgBuf;
DWORD dw = GetLastError ();
if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
| FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, dw,
MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &lpMsgBuf, 0, NULL)
== 0)
{
fprintf (stderr, "formatting the error message failed.\n");
ExitProcess (dw);
}
fprintf (stderr, "error spawning child: %ld, %s\n", dw,
(LPCTSTR) lpMsgBuf);
LocalFree (lpMsgBuf);
exit (1);
}
m->images[im.image_num] = (image_tracker) {pi.hProcess, IMAGE_OK};
process_handles[im.image_num] = waiting_handles[im.image_num]
= pi.hProcess;
thread_handles[im.image_num] = pi.hThread;
envs[im.image_num] = new_env;
#else
#error "no way known to start child processes."
#endif
}
for (int i = 0; i < local->total_num_images; i++)
{
#ifdef HAVE_FORK
caf_shmem_pid finished_pid = wait (&chstatus);
int j;
if (finished_pid == -1)
{
/* Skip wait having an issue. */
perror ("wait failed");
--i;
continue;
}
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++)
;
if (WEXITSTATUS (chstatus) == 210)
{
--i;
im.image_num = j;
++restarts;
if (restarts > restarts_limit)
{
kill_all_images (m);
caf_runtime_error (
"After restarting images %d times, no common state on "
"shared memory could be reached. Giving up...",
restarts);
exit (1);
}
if (startWorker (&im, argv))
return 1;
continue;
}
else
{
dprintf (2,
"ERROR: Image %d(pid: %d) failed with signal %d, "
"exitstatus %d.\n",
j + 1, finished_pid, WTERMSIG (chstatus),
WEXITSTATUS (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));
kill_all_images (m);
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++)
caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *,
m->sync_shared.sync_images_cond_vars,
&local->sm)[j]);
counter_barrier_add (&m->num_active_images, -1);
#elif defined(WIN32)
DWORD res = WaitForMultipleObjects (count_waiting, waiting_handles, FALSE,
INFINITE);
HANDLE cand;
bool progress = false;
DWORD process_exit_code;
if (res == WAIT_FAILED)
caf_runtime_error ("waiting for process termination failed.");
int index = res - WAIT_OBJECT_0, finished_process;
bool fail;
do
{
cand = waiting_handles[index];
for (finished_process = 0;
finished_process < local->total_num_images
&& cand != process_handles[finished_process];
++finished_process)
;
GetExitCodeProcess (cand, &process_exit_code);
fail = process_exit_code != 0;
fprintf (stderr, "terminating process %d with fail status %d (%ld)\n",
finished_process, fail, process_exit_code);
if (finished_process < local->total_num_images)
{
CloseHandle (process_handles[finished_process]);
process_handles[finished_process] = NULL;
CloseHandle (thread_handles[finished_process]);
FreeEnvironmentStrings (envs[finished_process]);
if (fail)
{
m->images[finished_process].status = IMAGE_FAILED;
atomic_fetch_add (&m->failed_images, 1);
if (*exit_code < process_exit_code)
*exit_code = process_exit_code;
}
else
{
m->images[finished_process].status = IMAGE_SUCCESS;
atomic_fetch_add (&m->finished_images, 1);
}
}
memmove (&waiting_handles[index], &waiting_handles[index + 1],
sizeof (HANDLE) * (count_waiting - index - 1));
--count_waiting;
counter_barrier_add (&m->num_active_images, -1);
/* Check if more than one process has terminated already. */
progress = false;
for (index = 0; index < count_waiting; ++index)
if (WaitForSingleObject (waiting_handles[index], 0)
== WAIT_OBJECT_0)
{
progress = true;
++i;
break;
}
}
while (progress && count_waiting > 0);
#endif
}
#if defined(WIN32) && !defined(HAVE_FORK)
free (process_handles);
free (thread_handles);
free (envs);
#endif
return 0;
}

119
libgfortran/caf/shmem/supervisor.h Normal file
View File

@ -0,0 +1,119 @@
/* 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
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#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
{
caf_shmem_pid 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;
caf_shmem_mutex image_tracker_lock;
#ifdef WIN32
size_t global_used_handles;
#endif
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

182
libgfortran/caf/shmem/sync.c Normal file
View File

@ -0,0 +1,182 @@
/* 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)
{
caf_shmem_mutex_lock (&si->cis->sync_images_table_lock);
}
static inline void
unlock_table (sync_t *si)
{
caf_shmem_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 (caf_shmem_condvar *,
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, num_images);
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 (caf_shmem_condvar) * num_images);
si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);
si->triggers
= SHMPTR_AS (caf_shmem_condvar *, si->cis->sync_images_cond_vars, ai->mem);
for (int i = 0; i < num_images; i++)
initialize_shared_condition (&si->triggers[i], num_images);
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];
caf_shmem_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;
caf_shmem_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];
caf_shmem_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;
caf_shmem_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)
{
caf_shmem_mutex_lock (&si->cis->event_lock);
}
void
unlock_event (sync_t *si)
{
caf_shmem_mutex_unlock (&si->cis->event_lock);
}
void
event_post (sync_t *si)
{
caf_shmem_cond_broadcast (&si->cis->event_cond);
}
void
event_wait (sync_t *si)
{
caf_shmem_cond_wait (&si->cis->event_cond, &si->cis->event_lock);
}

77
libgfortran/caf/shmem/sync.h Normal file
View File

@ -0,0 +1,77 @@
/* 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"
typedef struct {
/* Mutex and condition variable needed for signaling events. */
caf_shmem_mutex event_lock;
caf_shmem_condvar event_cond;
caf_shmem_mutex 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
caf_shmem_condvar *triggers;
} sync_t;
typedef caf_shmem_mutex 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

83
libgfortran/caf/shmem/teams_mgmt.c Normal file
View File

@ -0,0 +1,83 @@
/* 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)
{
caf_shmem_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);
}
caf_shmem_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;
}

93
libgfortran/caf/shmem/teams_mgmt.h Normal file
View File

@ -0,0 +1,93 @@
/* 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

381
libgfortran/caf/shmem/thread_support.c Executable file
View File

@ -0,0 +1,381 @@
/* 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>
#if !defined(WIN32) && !defined(__CYGWIN__)
#include <pthread.h>
#define ERRCHECK(a) \
do \
{ \
int rc = a; \
if (rc) \
{ \
errno = rc; \
perror (#a " failed"); \
exit (1); \
} \
} \
while (0)
void
initialize_shared_mutex (caf_shmem_mutex *mutex)
{
pthread_mutexattr_t mattr;
ERRCHECK (pthread_mutexattr_init (&mattr));
ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
#ifdef PTHREAD_MUTEX_ROBUST
ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST));
#endif
ERRCHECK (pthread_mutex_init (mutex, &mattr));
ERRCHECK (pthread_mutexattr_destroy (&mattr));
}
void
initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex)
{
pthread_mutexattr_t mattr;
ERRCHECK (pthread_mutexattr_init (&mattr));
ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));
ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));
#ifdef PTHREAD_MUTEX_ROBUST
ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST));
#endif
ERRCHECK (pthread_mutex_init (mutex, &mattr));
ERRCHECK (pthread_mutexattr_destroy (&mattr));
}
void
initialize_shared_condition (caf_shmem_condvar *cond, const int)
{
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));
}
#else
#include "../caf_error.h"
#include "supervisor.h"
#include "teams_mgmt.h"
#include <windows.h>
#include <assert.h>
static HANDLE *handles = NULL;
static size_t cap_handles = 0;
static const int ULONGBITS = sizeof (unsigned long) << 3; // *8
static size_t
smax (size_t a, size_t b)
{
return a < b ? b : a;
}
static HANDLE
get_handle (const size_t id, const char t)
{
const int add = t == 'c' ? 1 : 0;
while (id + add >= cap_handles)
{
cap_handles += 1024;
if (handles)
handles = realloc (handles, sizeof (HANDLE) * cap_handles);
else
handles = malloc (sizeof (HANDLE) * cap_handles);
if (!handles)
caf_runtime_error (
"can not get buffer for synchronication objects, aborting");
memset (&handles[cap_handles - 1024], 0, sizeof (HANDLE) * 1024);
}
if (!handles[id])
{
static char *pid = NULL;
char name[MAX_PATH];
if (!pid)
pid = shared_memory_get_env ();
snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd", pid, t, id);
switch (t)
{
case 'm':
handles[id] = CreateMutex (NULL, false, name);
break;
case 'c':
{
handles[id] = CreateSemaphore (NULL, 0, __INT_MAX__, name);
snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd_lock", pid, t,
id);
handles[id + 1] = CreateSemaphore (NULL, 1, 1, name);
this_image.supervisor->global_used_handles
= smax (this_image.supervisor->global_used_handles, id + 2);
break;
}
default:
caf_runtime_error ("Unknown handle type %c", t);
exit (1);
}
if (handles[id] == NULL)
{
caf_runtime_error (
"Could not create synchronisation object, error: %d",
GetLastError ());
return NULL;
}
this_image.supervisor->global_used_handles
= smax (this_image.supervisor->global_used_handles, id + 1);
}
return handles[id];
}
static HANDLE
get_mutex (caf_shmem_mutex *m)
{
return get_handle (m->id, 'm');
}
static HANDLE
get_condvar (caf_shmem_condvar *cv)
{
return get_handle (cv->id, 'c');
}
void
thread_support_init_supervisor (void)
{
if (local->total_num_images > ULONGBITS * MAX_NUM_SIGNALED)
caf_runtime_error ("Maximum number of supported images is %zd.",
ULONGBITS * MAX_NUM_SIGNALED);
this_image.supervisor->global_used_handles = 0;
}
int
caf_shmem_mutex_lock (caf_shmem_mutex *m)
{
HANDLE mutex = get_mutex (m);
DWORD res = WaitForSingleObject (mutex, INFINITE);
/* Return zero on success. */
return res != WAIT_OBJECT_0;
}
int
caf_shmem_mutex_trylock (caf_shmem_mutex *m)
{
HANDLE mutex = get_mutex (m);
DWORD res = WaitForSingleObject (mutex, 0);
return res == WAIT_OBJECT_0 ? 0 : EBUSY;
}
int
caf_shmem_mutex_unlock (caf_shmem_mutex *m)
{
HANDLE mutex = get_mutex (m);
BOOL res = ReleaseMutex (mutex);
if (!res)
{
LPVOID lpMsgBuf;
DWORD dw = GetLastError ();
if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER
| FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, dw, MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT),
(LPTSTR) &lpMsgBuf, 0, NULL)
== 0)
{
fprintf (stderr, "%d: formatting the error message failed.\n",
this_image.image_num);
ExitProcess (dw);
}
fprintf (stderr, "%d: unlock mutex failed: %d, %s\n",
this_image.image_num, dw, (LPCTSTR) lpMsgBuf);
LocalFree (lpMsgBuf);
}
return res ? 0 : EPERM;
}
static bool
bm_is_set (volatile unsigned long mask[], const int b)
{
return (mask[b / ULONGBITS] & (1UL << (b % ULONGBITS))) != 0;
}
static void
bm_clear_bit (volatile unsigned long mask[], const int b)
{
mask[b / ULONGBITS] &= ~(1UL << (b % ULONGBITS));
}
static void
bm_set_mask (volatile unsigned long mask[], const int size)
{
const int entries = size / ULONGBITS;
const int rem = size % ULONGBITS;
int i = 0;
assert (entries >= 0);
for (; i < entries; ++i)
mask[i] = ~0UL;
if (rem != 0)
mask[i] = ~0UL >> (ULONGBITS - rem);
}
__attribute__ ((used)) static bool
bm_is_none (volatile unsigned long mask[], const int size)
{
const int entries = size / ULONGBITS;
const int rem = size % ULONGBITS;
int i = 0;
for (; i < entries; ++i)
if (mask[i] != 0)
return false;
return rem == 0 || ((mask[i] & (~0UL >> (ULONGBITS - rem))) == 0);
}
void
caf_shmem_cond_wait (caf_shmem_condvar *cv, caf_shmem_mutex *m)
{
HANDLE mutex = get_mutex (m), condvar = get_condvar (cv),
lock = get_handle (cv->id + 1, 'c');
HANDLE entry[3] = {mutex, condvar, lock};
int res;
WaitForSingleObject (lock, INFINITE);
for (;;)
{
if (bm_is_set (cv->signaled, this_image.image_num) || cv->any)
{
break;
}
ReleaseMutex (mutex);
ReleaseSemaphore (lock, 1, NULL);
res = WaitForMultipleObjects (3, entry, true, INFINITE);
if (res != WAIT_OBJECT_0)
{
fprintf (stderr, "%d: failed to get all wait for: %d\n",
this_image.image_num, res);
fflush (stderr);
}
ReleaseSemaphore (condvar, 1, NULL);
}
res = WaitForSingleObject (condvar, INFINITE);
if (res != WAIT_OBJECT_0)
{
fprintf (stderr, "%d: failed to get condvar: %d\n", this_image.image_num,
res);
fflush (stderr);
}
bm_clear_bit (cv->signaled, this_image.image_num);
cv->any = 0;
ReleaseSemaphore (lock, 1, NULL);
}
void
caf_shmem_cond_broadcast (caf_shmem_condvar *cv)
{
HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
WaitForSingleObject (lock, INFINITE);
bm_set_mask (cv->signaled, cv->size);
bm_clear_bit (cv->signaled, this_image.image_num);
ReleaseSemaphore (condvar, cv->size, NULL);
ReleaseSemaphore (lock, 1, NULL);
}
void
caf_shmem_cond_signal (caf_shmem_condvar *cv)
{
HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c');
if (caf_current_team)
{
WaitForSingleObject (lock, INFINITE);
}
else
return;
/* The first image is zero, which wouldn't allow it to signal. */
cv->any = this_image.image_num + 1;
ReleaseSemaphore (condvar, 1, NULL);
ReleaseSemaphore (lock, 1, NULL);
}
void
caf_shmem_cond_update_count (caf_shmem_condvar *cv, int val)
{
cv->size += val;
}
void
initialize_shared_mutex (caf_shmem_mutex *m)
{
*m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
get_mutex (m);
}
void
initialize_shared_errorcheck_mutex (caf_shmem_mutex *m)
{
*m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles};
get_mutex (m);
}
void
initialize_shared_condition (caf_shmem_condvar *cv, const int size)
{
*cv = (caf_shmem_condvar) {this_image.supervisor->global_used_handles,
0,
size,
{}};
memset ((void *) cv->signaled, 0, sizeof (unsigned long) * MAX_NUM_SIGNALED);
get_condvar (cv);
assert (bm_is_none (cv->signaled, cv->size));
}
void
thread_support_cleanup (void)
{
for (size_t i = 0; i < this_image.supervisor->global_used_handles; ++i)
if (handles[i])
CloseHandle (handles[i]);
}
#endif

113
libgfortran/caf/shmem/thread_support.h Executable file
View File

@ -0,0 +1,113 @@
/* 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
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#ifndef WIN32
#include <sys/types.h>
typedef pid_t caf_shmem_pid;
typedef int caf_shmem_fd;
#else
#include <handleapi.h>
typedef HANDLE caf_shmem_pid;
typedef HANDLE caf_shmem_fd;
#endif
#if !defined(WIN32) && !defined(__CYGWIN__)
#include <pthread.h>
typedef pthread_mutex_t caf_shmem_mutex;
typedef pthread_cond_t caf_shmem_condvar;
#define CAF_SHMEM_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER
#define CAF_SHMEM_COND_INITIALIZER PTHREAD_COND_INITIALIZER
#define thread_support_init_supervisor() (void) 0
#define caf_shmem_mutex_lock pthread_mutex_lock
#define caf_shmem_mutex_trylock pthread_mutex_trylock
#define caf_shmem_mutex_unlock pthread_mutex_unlock
#define caf_shmem_cond_wait pthread_cond_wait
#define caf_shmem_cond_broadcast pthread_cond_broadcast
#define caf_shmem_cond_signal pthread_cond_signal
#define caf_shmem_cond_update_count(c, v) (void) 0
#define thread_support_cleanup() (void) 0
#else
#include <synchapi.h>
#include <stddef.h>
typedef struct caf_shmem_mutex
{
size_t id;
} caf_shmem_mutex;
#define MAX_NUM_SIGNALED 8
typedef struct caf_shmem_condvar
{
size_t id;
volatile int any;
int size;
volatile unsigned long signaled[MAX_NUM_SIGNALED];
} caf_shmem_condvar;
#define CAF_SHMEM_MUTEX_INITIALIZER (caf_shmem_mutex){0}
#define CAF_SHMEM_COND_INITIALIZER \
(caf_shmem_condvar) \
{ \
0, 0, 0, {} \
}
void thread_support_init_supervisor (void);
int caf_shmem_mutex_lock (caf_shmem_mutex *);
int caf_shmem_mutex_trylock (caf_shmem_mutex *);
int caf_shmem_mutex_unlock (caf_shmem_mutex *);
void caf_shmem_cond_wait (caf_shmem_condvar *, caf_shmem_mutex *);
void caf_shmem_cond_broadcast (caf_shmem_condvar *);
void caf_shmem_cond_signal (caf_shmem_condvar *);
void caf_shmem_cond_update_count (caf_shmem_condvar *, int);
void thread_support_cleanup (void);
#endif
/* Support routines to setup pthread structs in shared memory. */
void initialize_shared_mutex (caf_shmem_mutex *);
void initialize_shared_errorcheck_mutex (caf_shmem_mutex *);
void initialize_shared_condition (caf_shmem_condvar *, const int size);
#endif

2
libgfortran/caf/single.c
View File

@ -129,7 +129,7 @@ caf_internal_error (const char *msg, int *stat, char *errmsg,
*stat = 1;
if (errmsg_len > 0)
{
int len = snprintf (errmsg, errmsg_len, msg, args);
int len = vsnprintf (errmsg, errmsg_len, msg, args);
if (len >= 0 && errmsg_len > (size_t) len)
memset (&errmsg[len], ' ', errmsg_len - len);
}

12
libgfortran/config.h.in
View File

@ -777,6 +777,9 @@
/* Define to 1 if you have the `mkstemp' function. */
#undef HAVE_MKSTEMP
/* Define to 1 if you have the `mmap' function. */
#undef HAVE_MMAP
/* Define to 1 if you have the `newlocale' function. */
#undef HAVE_NEWLOCALE
@ -828,6 +831,9 @@
/* Define to 1 if you have the `roundl' function. */
#undef HAVE_ROUNDL
/* Define if __builtin_clzl behaves as expected. */
#undef HAVE_SANE_BUILTIN_CLZL
/* Define to 1 if you have the `scalbn' function. */
#undef HAVE_SCALBN
@ -843,6 +849,9 @@
/* Define to 1 if you have the `secure_getenv' function. */
#undef HAVE_SECURE_GETENV
/* Define to 1 if you have the `setenv' function. */
#undef HAVE_SETENV
/* Define to 1 if you have the `setmode' function. */
#undef HAVE_SETMODE
@ -945,6 +954,9 @@
/* Define to 1 if you have the `symlink' function. */
#undef HAVE_SYMLINK
/* Define to 1 if you have the <sys/mman.h> header file. */
#undef HAVE_SYS_MMAN_H
/* Define to 1 if you have the <sys/random.h> header file. */
#undef HAVE_SYS_RANDOM_H

74
libgfortran/configure vendored
View File

@ -637,6 +637,8 @@ am__EXEEXT_TRUE
LTLIBOBJS
LIBOBJS
get_gcc_base_ver
HAVE_SANE_BUILTIN_CLZL_FALSE
HAVE_SANE_BUILTIN_CLZL_TRUE
HAVE_AVX128_FALSE
HAVE_AVX128_TRUE
tmake_file
@ -2619,6 +2621,7 @@ as_fn_append ac_header_list " fpxcp.h"
as_fn_append ac_header_list " pwd.h"
as_fn_append ac_header_list " complex.h"
as_fn_append ac_header_list " xlocale.h"
as_fn_append ac_header_list " sys/mman.h"
as_fn_append ac_func_list " getrusage"
as_fn_append ac_func_list " times"
as_fn_append ac_func_list " mkstemp"
@ -2638,6 +2641,8 @@ as_fn_append ac_func_list " sleep"
as_fn_append ac_func_list " ttyname"
as_fn_append ac_func_list " sigaction"
as_fn_append ac_func_list " waitpid"
as_fn_append ac_func_list " mmap"
as_fn_append ac_func_list " setenv"
as_fn_append ac_func_list " alarm"
as_fn_append ac_func_list " access"
as_fn_append ac_func_list " fork"
@ -12847,7 +12852,7 @@ else
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
#line 12850 "configure"
#line 12855 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
@ -12953,7 +12958,7 @@ else
lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
lt_status=$lt_dlunknown
cat > conftest.$ac_ext <<_LT_EOF
#line 12956 "configure"
#line 12961 "configure"
#include "confdefs.h"
#if HAVE_DLFCN_H
@ -16738,6 +16743,8 @@ done
@ -17339,6 +17346,10 @@ done
@ -31438,6 +31449,57 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
CFLAGS="$ac_save_CFLAGS"
# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64).
if test "$cross_compiling" = yes; then :
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error $? "cannot run test program while cross compiling
See \`config.log' for more details" "$LINENO" 5; }
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
int main()
{
return __builtin_clzl(256) != 8;
}
int
main ()
{
;
return 0;
}
_ACEOF
if ac_fn_c_try_run "$LINENO"; then :
$as_echo "#define HAVE_SANE_BUILTIN_CLZL 1" >>confdefs.h
if true; then
HAVE_SANE_BUILTIN_CLZL_TRUE=
HAVE_SANE_BUILTIN_CLZL_FALSE='#'
else
HAVE_SANE_BUILTIN_CLZL_TRUE='#'
HAVE_SANE_BUILTIN_CLZL_FALSE=
fi
else
if false; then
HAVE_SANE_BUILTIN_CLZL_TRUE=
HAVE_SANE_BUILTIN_CLZL_FALSE='#'
else
HAVE_SANE_BUILTIN_CLZL_TRUE='#'
HAVE_SANE_BUILTIN_CLZL_FALSE=
fi
fi
rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \
conftest.$ac_objext conftest.beam conftest.$ac_ext
fi
# Determine what GCC version number to use in filesystem paths.
get_gcc_base_ver="cat"
@ -31729,6 +31791,14 @@ if test -z "${HAVE_AVX128_TRUE}" && test -z "${HAVE_AVX128_FALSE}"; then
as_fn_error $? "conditional \"HAVE_AVX128\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then
as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then
as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined.
Usually this means the macro was only invoked conditionally." "$LINENO" 5
fi
: "${CONFIG_STATUS=./config.status}"
ac_write_fail=0

7
libgfortran/configure.ac
View File

@ -298,7 +298,7 @@ AC_CHECK_TYPES([ptrdiff_t])
AC_CHECK_HEADERS_ONCE(unistd.h sys/random.h sys/time.h sys/times.h \
sys/resource.h sys/types.h sys/stat.h sys/uio.h sys/wait.h \
floatingpoint.h ieeefp.h fenv.h fptrap.h \
fpxcp.h pwd.h complex.h xlocale.h)
fpxcp.h pwd.h complex.h xlocale.h sys/mman.h)
GCC_HEADER_STDINT(gstdint.h)
@ -334,7 +334,7 @@ if test "${hardwire_newlib:-0}" -eq 1; then
else
AC_CHECK_FUNCS_ONCE(getrusage times mkstemp strtof strtold snprintf \
ftruncate chsize chdir getentropy getlogin gethostname kill link symlink \
sleep ttyname sigaction waitpid \
sleep ttyname sigaction waitpid mmap setenv\
alarm access fork posix_spawn setmode fcntl writev \
gettimeofday stat fstat lstat getpwuid vsnprintf dup \
getcwd localtime_r gmtime_r getpwuid_r ttyname_r clock_gettime \
@ -789,6 +789,9 @@ LIBGFOR_CHECK_FMA4
# Check if AVX128 works
LIBGFOR_CHECK_AVX128
# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64).
LIBGFOR_CHECK_SANE_BUILTIN_CLZL
# Determine what GCC version number to use in filesystem paths.
GCC_BASE_VER