From: Jerry DeLisle Date: Tue, 29 Jul 2025 17:59:18 +0000 (-0700) Subject: Fortran: Recommit changes for coarray after merging. X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=9ddef25c1812bf0b9c75634013b1fbcd94eca5a4;p=thirdparty%2Fgcc.git Fortran: Recommit changes for coarray after merging. Testing only. Work in progress. gcc/fortran/ChangeLog: * check.cc (gfc_check_image_status): Modify (gfc_check_failed_or_stopped_images): Modify * coarray.cc (check_add_new_component): Modify * invoke.texi: Modify * trans-decl.cc (gfc_build_builtin_function_decls): Modify * trans-expr.cc (get_scalar_to_descriptor_type): Modify (copy_coarray_desc_part): Modify (gfc_class_array_data_assign): Modify (gfc_conv_derived_to_class): Modify * trans-intrinsic.cc (conv_intrinsic_image_status): Modify * trans-stmt.cc (gfc_trans_sync): Modify libgfortran/ChangeLog: * Makefile.am: Modify * Makefile.in: Modify * caf/libcaf.h (LIBCAF_H): Modify (_gfortran_caf_failed_images): Modify (_gfortran_caf_image_status): Modify (_gfortran_caf_stopped_images): Modify * caf/single.c (caf_internal_error): Modify * caf/caf_error.c: New file. Modify * caf/caf_error.h: New file. Modify * caf/shmem.c: New file. * caf/shmem/alloc.c: New file. * caf/shmem/alloc.h: New file. * caf/shmem/allocator.c: New file. * caf/shmem/allocator.h: New file. * caf/shmem/collective_subroutine.c: New file. * caf/shmem/collective_subroutine.h: New file. * caf/shmem/counter_barrier.c: New file. * caf/shmem/counter_barrier.h: New file. * caf/shmem/hashmap.c: New file. * caf/shmem/hashmap.h: New file. * caf/shmem/shared_memory.c: New file. * caf/shmem/shared_memory.h: New file. * caf/shmem/supervisor.c: New file. * caf/shmem/supervisor.h: New file. * caf/shmem/sync.c: New file. * caf/shmem/sync.h: New file. * caf/shmem/teams_mgmt.c: New file. * caf/shmem/teams_mgmt.h: New file. * caf/shmem/thread_support.c: New file. * caf/shmem/thread_support.h: New file. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/alloc_comp_4.f90: Modify * gfortran.dg/coarray/atomic_2.f90: Modify * gfortran.dg/coarray/caf.exp: Modify * gfortran.dg/coarray/coarray_allocated.f90: Modify * gfortran.dg/coarray/coindexed_1.f90: Modify * gfortran.dg/coarray/coindexed_3.f08: Modify * gfortran.dg/coarray/coindexed_5.f90: Modify * gfortran.dg/coarray/dummy_3.f90: Modify * gfortran.dg/coarray/event_1.f90: Modify * gfortran.dg/coarray/event_3.f08: Modify * gfortran.dg/coarray/event_4.f08: Modify * gfortran.dg/coarray/failed_images_1.f08: Modify * gfortran.dg/coarray/failed_images_2.f08: Modify * gfortran.dg/coarray/image_status_1.f08: Modify * gfortran.dg/coarray/image_status_2.f08: Modify * gfortran.dg/coarray/lock_2.f90: Modify * gfortran.dg/coarray/poly_run_3.f90: Modify * gfortran.dg/coarray/scalar_alloc_1.f90: Modify * gfortran.dg/coarray/stopped_images_1.f08: Modify * gfortran.dg/coarray/stopped_images_2.f08: Modify * gfortran.dg/coarray/sync_1.f90: Modify * gfortran.dg/coarray/sync_3.f90: Modify * gfortran.dg/coarray_sync_memory.f90: Modify * gfortran.dg/coarray/co_reduce_string.f90: New test. Modify * gfortran.dg/coarray/sync_team.f90: New test. Modify --- diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 838d523f7c4..3446c88b501 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1835,7 +1835,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)); } @@ -1878,13 +1878,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) { diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index ef8fd4e42d0..c611b539968 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -696,17 +696,23 @@ check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data) check_add_new_component (type, actual->expr, add_data); break; case EXPR_FUNCTION: - if (!e->symtree->n.sym->attr.pure - && !e->symtree->n.sym->attr.elemental - && !(e->value.function.isym - && (e->value.function.isym->pure - || e->value.function.isym->elemental))) - /* Treat non-pure/non-elemental functions. */ - check_add_new_comp_handle_array (e, type, add_data); + if ((e->symtree->n.sym->attr.pure + && e->symtree->n.sym->attr.elemental) + || (e->value.function.isym && e->value.function.isym->pure + && e->value.function.isym->elemental)) + { + /* Only allow pure and elemental function calls in a coarray + accessor, because all other may have side effects or access + pointers, which may not be possible in the accessor running on + another host. */ + for (gfc_actual_arglist *actual = e->value.function.actual; + actual; actual = actual->next) + check_add_new_component (type, actual->expr, add_data); + } else - for (gfc_actual_arglist *actual = e->value.function.actual; actual; - actual = actual->next) - check_add_new_component (type, actual->expr, add_data); + /* Extract the expression, evaluate it and add a temporary with its + value to the helper structure. */ + check_add_new_comp_handle_array (e, type, add_data); break; case EXPR_VARIABLE: check_add_new_comp_handle_array (e, type, add_data); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 0b893e876a5..77926fa0259 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -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 @@ -2280,3 +2281,56 @@ 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! + +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 diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index d5acdca719f..2cfddfea15b 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4223,10 +4223,9 @@ gfc_build_builtin_function_decls (void) get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node, size_type_node); - gfor_fndecl_caf_team_number - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_team_number")), ". r ", - integer_type_node, 1, integer_type_node); + gfor_fndecl_caf_team_number = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_team_number")), ". r ", integer_type_node, + 1, pvoid_type_node); gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX ("caf_image_status")), ". r r ", diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 0db7ba3fd52..c5ccfaa9c90 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -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 (lhs_dim) : TREE_TYPE (rhs_dim); + lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, lhs_dim, rhs_dim); - type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); - tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - gfc_add_modify (block, tmp, tmp2); + /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ + copy_coarray_desc_part (block, lhs_desc, rhs_desc); } /* Takes a derived type expression and returns the address of a temporary @@ -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), diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index be984271d6a..7cd95da7116 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -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 (); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f1054015862..eadd40cafd8 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -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) { diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 index 2ee8ff0253d..50b4bab1603 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 index 5e1c4967248..7eccd7b578c 100644 --- a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp index c1e8e8ca2b0..1f002e08fa3 100644 --- a/gcc/testsuite/gfortran.dg/coarray/caf.exp +++ b/gcc/testsuite/gfortran.dg/coarray/caf.exp @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 b/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 new file mode 100644 index 00000000000..9b4c44f1ada --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 index 27db0e8d8ce..ce7c6288a61 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 index f90b65cb389..8f7a83a9c99 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 index 7fd20851e0a..145835d461b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 index c35ec1093c1..8eb64669628 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 index 4b45daab649..c569390e7c6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 index 81dc90b7197..a9fecf93984 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 @@ -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 - -stat = 99 -event post (var, stat=stat) -if (stat /= 0) STOP 2 -call event_query(var, count, stat=stat) -if (count /= 1 .or. stat /= 0) STOP 3 - -stat = 99 -event post (var[this_image()]) -call event_query(var, count) -if (count /= 2) STOP 4 - -stat = 99 -event wait (var) -call event_query(var, count) -if (count /= 1) STOP 5 - -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 2) STOP 6 - -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 3) STOP 7 - -stat = 99 -event wait (var, until_count=2) -call event_query(var, count) -if (count /= 1) STOP 8 - -stat = 99 -event wait (var, stat=stat, until_count=1) -if (stat /= 0) STOP 9 -call event_query(event=var, stat=stat, count=count) -if (count /= 0 .or. stat /= 0) STOP 10 +associate (me => this_image(), np => num_images()) + allocate(events(np)[*]) + + associate(var => events(me)) + count = -42 + call event_query (var, count) + if (count /= 0) STOP 1 + + stat = 99 + event post (var, stat=stat) + if (stat /= 0) STOP 2 + call event_query(var, count, stat=stat) + if (count /= 1 .or. stat /= 0) STOP 3 + + count = 99 + event post (var[this_image()]) + call event_query(var, count) + if (count /= 2) STOP 4 + + count = 99 + event wait (var) + call event_query(var, count) + if (count /= 1) STOP 5 + + count = 99 + event post (var) + call event_query(var, count) + if (count /= 2) STOP 6 + + count = 99 + event post (var) + call event_query(var, count) + if (count /= 3) STOP 7 + + count = 99 + event wait (var, until_count=2) + call event_query(var, count) + if (count /= 1) STOP 8 + + stat = 99 + event wait (var, stat=stat, until_count=1) + if (stat /= 0) STOP 9 + count = 99 + call event_query(event=var, stat=stat, count=count) + if (count /= 0 .or. stat /= 0) STOP 10 + end associate +end associate end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index 60d3193f776..cedf636b79b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 index de901c01aa4..26a1f59df03 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 index 4898dd8a7a2..34ae131d15f 100644 --- a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 index ca5fe4020d5..78d92daf071 100644 --- a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index b7ec5a6a9c9..f725f81d4aa 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 @@ -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\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 index fb49289cb78..8866f237481 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 index 8e96154996d..3d445b9b5e8 100644 --- a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 @@ -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) diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 index c284a566760..4da1b9569fe 100644 --- a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 index b0d27bdfb8f..8dd7df5d436 100644 --- a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 index 403de585b9a..7658e6bb6bb 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 @@ -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" } diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 index 0bf4a81a7e2..dadd00ecda7 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 index 8633c4aa527..4abe5a3b548 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 index fe1e4c548c8..ceb4b19d517 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 new file mode 100644 index 00000000000..a96884549a3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 b/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 index c4e660b8cf7..0030d91257d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_sync_memory.f90 @@ -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" } } diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 4f3b3033224..f912824d208 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -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 diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index dd88f8893b7..003c2f13362 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -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,9 +1991,40 @@ 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) +libcaf_single.la: $(libcaf_single_la_OBJECTS) $(libcaf_single_la_DEPENDENCIES) $(EXTRA_libcaf_single_la_DEPENDENCIES) $(AM_V_GEN)$(libcaf_single_la_LINK) -rpath $(cafexeclibdir) $(libcaf_single_la_OBJECTS) $(libcaf_single_la_LIBADD) $(LIBS) runtime/$(am__dirstamp): @$(MKDIR_P) runtime @@ -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 diff --git a/libgfortran/caf/caf_error.c b/libgfortran/caf/caf_error.c new file mode 100644 index 00000000000..a8f3bf7f189 --- /dev/null +++ b/libgfortran/caf/caf_error.c @@ -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 +. */ + +#include "caf_error.h" + +#include +#include +#include +#include + +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); +} diff --git a/libgfortran/caf/caf_error.h b/libgfortran/caf/caf_error.h new file mode 100644 index 00000000000..15455377eb0 --- /dev/null +++ b/libgfortran/caf/caf_error.h @@ -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 +. */ + +#ifndef CAF_ERROR_H +#define CAF_ERROR_H + +#include + +/* 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 diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 7267bc76905..80ea72ff742 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -26,9 +26,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #ifndef LIBCAF_H #define LIBCAF_H -#include -#include /* 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); diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c new file mode 100644 index 00000000000..b8d92d657f5 --- /dev/null +++ b/libgfortran/caf/shmem.c @@ -0,0 +1,1882 @@ +/* Shared memory-multiple (process)-image implementation of GNU Fortran + Coarray Library + Copyright (C) 2011-2025 Free Software Foundation, Inc. + Based on single.c contributed by Tobias Burnus + +This file is part of the GNU Fortran Coarray Runtime Library (libcaf). + +Libcaf is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Libcaf is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libcaf.h" +#include "caf_error.h" + +#include "shmem/counter_barrier.h" +#include "shmem/supervisor.h" +#include "shmem/teams_mgmt.h" +#include "shmem/thread_support.h" + +#include /* For exit and malloc. */ +#include /* For memcpy and memset. */ +#include +#include +#include +#include + +/* Define GFC_CAF_CHECK to enable run-time checking. */ +/* #define GFC_CAF_CHECK 1 */ + +#define TOKEN(X) ((caf_shmem_token_t) (X)) +#define MEMTOK(X) ((caf_shmem_token_t) (X))->memptr + +/* Global variables. */ +static caf_static_t *caf_static_list = NULL; +memid next_memid = 0; + +typedef void (*getter_t) (void *, const int *, void **, int32_t *, void *, + caf_token_t, const size_t, size_t *, const size_t *); +typedef void (*is_present_t) (void *, const int *, int32_t *, void *, + caf_shmem_token_t, const size_t); +typedef void (*receiver_t) (void *, const int *, void *, const void *, + caf_token_t, const size_t, const size_t *, + const size_t *); +struct accessor_hash_t +{ + int hash; + int pad; + union + { + getter_t getter; + is_present_t is_present; + receiver_t receiver; + } u; +}; + +static struct accessor_hash_t *accessor_hash_table = NULL; +static int aht_cap = 0; +static int aht_size = 0; +static enum { + AHT_UNINITIALIZED, + AHT_OPEN, + AHT_PREPARED +} accessor_hash_table_state + = AHT_UNINITIALIZED; + +void +_gfortran_caf_init (int *argc, char ***argv) +{ + int exit_code = 0; + + ensure_shmem_initialization (); + + if (shared_memory_get_env ()) + { + /* This is the initialization of a worker. */ + _gfortran_caf_sync_all (NULL, NULL, 0); + return; + } + + if (supervisor_main_loop (argc, argv, &exit_code)) + return; + shared_memory_cleanup (&local->sm); + + /* Free pseudo tokens and memory to allow main process to survive caf_init. + */ + while (caf_static_list != NULL) + { + caf_static_t *tmp = caf_static_list->prev; + free (((caf_shmem_token_t) caf_static_list->token)->base); + free (caf_static_list->token); + free (caf_static_list); + caf_static_list = tmp; + } + free (local); + exit (exit_code); +} + +static void +free_team_list (caf_shmem_team_t l) +{ + while (l != NULL) + { + caf_shmem_team_t p = l->parent; + struct coarray_allocated *ca = l->allocated; + while (ca) + { + struct coarray_allocated *nca = ca->next; + free (ca); + ca = nca; + } + free (l); + l = p; + } +} + +void +_gfortran_caf_finalize (void) +{ + free (accessor_hash_table); + + while (caf_static_list != NULL) + { + caf_static_t *tmp = caf_static_list->prev; + alloc_free_memory_with_id ( + &local->ai, + (memid) ((caf_shmem_token_t) caf_static_list->token)->token_id); + free (caf_static_list->token); + free (caf_static_list); + caf_static_list = tmp; + } + + free_team_list (caf_current_team); + caf_initial_team = caf_current_team = NULL; + free_team_list (caf_teams_formed); + caf_teams_formed = NULL; + + free (local); +} + +int +_gfortran_caf_this_image (caf_team_t team) +{ + return (team ? ((caf_shmem_team_t) team)->index : caf_current_team->index) + + 1; +} + +int +_gfortran_caf_num_images (caf_team_t team, int32_t *team_number) +{ +#define CHECK_TEAMS \ + while (cur) \ + { \ + if (cur->u.image_info->team_id == *team_number) \ + return counter_barrier_get_count (&cur->u.image_info->image_count); \ + cur = cur->parent; \ + } + + if (team) + return counter_barrier_get_count ( + &((caf_shmem_team_t) team)->u.image_info->image_count); + + if (team_number) + { + caf_shmem_team_t cur = caf_current_team; + + CHECK_TEAMS + + cur = caf_teams_formed; + CHECK_TEAMS + } + + return counter_barrier_get_count ( + &caf_current_team->u.image_info->image_count); +} + + +void +_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, + gfc_descriptor_t *data, int *stat, char *errmsg, + size_t errmsg_len) +{ + static bool inited = false; + const char alloc_fail_msg[] = "Failed to allocate coarray"; + void *mem; + caf_shmem_token_t shmem_token; + + /* When the master has not been initialized, we could either be in the + control process or in the static initializer phase. */ + if (unlikely (!inited)) + { + if (local == NULL) + { + if (shared_memory_get_env ()) + { + /* This is the static initializer phase. Register the static + coarrays or we are in trouble later. */ + ensure_shmem_initialization (); + inited = true; + } + else if (type == CAF_REGTYPE_COARRAY_STATIC) + { + /* This is the control process, but it also runs the static + initializers (the caf_init.N() procedures). In these it may + want to assign to members (effectively NULL them) of derived + types. Therefore the need to return valid memory blocks. + These are never used and do not participate in any coarray + routine. They unfortunately just waste some memory. */ + mem = malloc (size); + GFC_DESCRIPTOR_DATA (data) = mem; + caf_static_t *tmp = malloc (sizeof (caf_static_t)); + *token = malloc (sizeof (struct caf_shmem_token)); + **(caf_shmem_token_t *) token + = (struct caf_shmem_token) {mem, NULL, mem, size, ~0U, true}; + *tmp = (caf_static_t) {*token, caf_static_list}; + caf_static_list = tmp; + return; + } + else + return; + } + } + + /* Catch all special cases. */ + switch (type) + { + /* When mapping, read from the old token. */ + case CAF_REGTYPE_COARRAY_MAP_EXISTING: + /* The mapping could involve an offset that is mangled into the array's + data ptr. */ + mem + = ((caf_shmem_token_t) *token)->base + + (GFC_DESCRIPTOR_DATA (data) - ((caf_shmem_token_t) *token)->memptr); + size = ((caf_shmem_token_t) *token)->image_size; + break; + case CAF_REGTYPE_EVENT_ALLOC: + case CAF_REGTYPE_EVENT_STATIC: + size *= sizeof (void *); + break; + default: + break; + } + + if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY) + *token = malloc (sizeof (struct caf_shmem_token)); + + size = alignto (size, sizeof (ptrdiff_t)); + switch (type) + { + case CAF_REGTYPE_LOCK_STATIC: + case CAF_REGTYPE_LOCK_ALLOC: + case CAF_REGTYPE_CRITICAL: + { + lock_t *addr; + bool created; + + allocator_lock (&local->ai.alloc); + /* Allocate enough space for the metadata infront of the lock + array. */ + addr + = alloc_get_memory_by_id_created (&local->ai, size * sizeof (lock_t), + next_memid, &created); + + if (created) + { + /* Initialize the mutex only, when the memory was allocated for the + first time. */ + for (size_t c = 0; c < size; ++c) + initialize_shared_errorcheck_mutex (&addr[c]); + } + size *= sizeof (lock_t); + + allocator_unlock (&local->ai.alloc); + mem = addr; + break; + } + case CAF_REGTYPE_EVENT_STATIC: + case CAF_REGTYPE_EVENT_ALLOC: + { + bool created; + + allocator_lock (&local->ai.alloc); + mem = alloc_get_memory_by_id_created ( + &local->ai, size * caf_current_team->u.image_info->image_count.count, + next_memid, &created); + if (created) + memset (mem, 0, + size * caf_current_team->u.image_info->image_count.count); + allocator_unlock (&local->ai.alloc); + } + break; + case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY: + mem = NULL; + break; + case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY: + allocator_lock (&local->ai.alloc); + mem = SHMPTR_AS (void *, allocator_shared_malloc (&local->ai.alloc, size), + &local->sm); + allocator_unlock (&local->ai.alloc); + break; + case CAF_REGTYPE_COARRAY_MAP_EXISTING: + /* Computing the mem ptr is done above before the new token is allocated. + */ + break; + default: + mem = alloc_get_memory_by_id ( + &local->ai, size * caf_current_team->u.image_info->image_count.count, + next_memid); + break; + } + + if (unlikely ( + *token == NULL + || (mem == NULL && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY))) + { + /* Freeing the memory conditionally seems pointless, but + caf_internal_error () may return, when a stat is given and then the + memory may be lost. */ + if (mem) + alloc_free_memory_with_id (&local->ai, next_memid); + free (*token); + caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len); + return; + } + + shmem_token = TOKEN (*token); + switch (type) + { + case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY: + *shmem_token + = (struct caf_shmem_token) {NULL, NULL, NULL, size, ~0U, false}; + break; + case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY: + shmem_token->memptr = mem; + shmem_token->base = mem; + shmem_token->image_size = size; + shmem_token->owning_memory = true; + break; + case CAF_REGTYPE_COARRAY_MAP_EXISTING: + *shmem_token + = (struct caf_shmem_token) {mem + size * this_image.image_num, + GFC_DESCRIPTOR_RANK (data) > 0 ? data + : NULL, + mem, + size, + next_memid++, + false}; + break; + case CAF_REGTYPE_LOCK_STATIC: + case CAF_REGTYPE_LOCK_ALLOC: + case CAF_REGTYPE_CRITICAL: + *shmem_token = (struct caf_shmem_token) { + mem, GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL, + mem, size, + next_memid++, false}; + break; + default: + *shmem_token + = (struct caf_shmem_token) {mem + size * this_image.image_num, + GFC_DESCRIPTOR_RANK (data) > 0 ? data + : NULL, + mem, + size, + next_memid++, + true}; + break; + } + + if (stat) + *stat = 0; + + if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC + || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC) + { + caf_static_t *tmp = malloc (sizeof (caf_static_t)); + *tmp = (caf_static_t) {*token, caf_static_list}; + caf_static_list = tmp; + } + else + { + struct coarray_allocated *ca = caf_current_team->allocated; + for (; ca && ca->token != shmem_token; ca = ca->next) + ; + if (!ca) + { + ca = (struct coarray_allocated *) malloc ( + sizeof (struct coarray_allocated)); + *ca = (struct coarray_allocated) {caf_current_team->allocated, + shmem_token}; + caf_current_team->allocated = ca; + } + } + GFC_DESCRIPTOR_DATA (data) = shmem_token->memptr; +} + +void +_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + caf_shmem_token_t shmem_token = TOKEN (*token); + + if (shmem_token->owning_memory && shmem_token->memptr) + { + if (shmem_token->token_id != ~0U) + alloc_free_memory_with_id (&local->ai, (memid) shmem_token->token_id); + else + { + allocator_lock (&local->ai.alloc); + allocator_shared_free (&local->ai.alloc, + AS_SHMPTR (shmem_token->base, local->sm), + shmem_token->image_size); + allocator_unlock (&local->ai.alloc); + } + + if (shmem_token->desc) + GFC_DESCRIPTOR_DATA (shmem_token->desc) = NULL; + } + + if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) + { + struct coarray_allocated *ca = caf_current_team->allocated; + if (ca && caf_current_team->allocated->token == shmem_token) + caf_current_team->allocated = ca->next; + else + { + struct coarray_allocated *pca = NULL; + for (; ca && ca->token != shmem_token; pca = ca, ca = ca->next) + ; + if (!ca) + caf_runtime_error ( + "Coarray token to be freeed is not in current team %d", type); + /* Unhook found coarray_allocated node from list... */ + pca->next = ca->next; + } + /* ... and free. */ + free (ca); + free (TOKEN (*token)); + *token = NULL; + } + else + { + shmem_token->memptr = NULL; + shmem_token->owning_memory = false; + } + + if (stat) + *stat = 0; +} + +void +_gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len) +{ + __asm__ __volatile__ ("":::"memory"); + HEALTH_CHECK (stat, errmsg, errmsg_len); + CHECK_TEAM_INTEGRITY (caf_current_team); + sync_all (); +} + + +void +_gfortran_caf_sync_memory (int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + __asm__ __volatile__ ("":::"memory"); + if (stat) + *stat = 0; +} + +void +_gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, + size_t errmsg_len) +{ + int *mapped_images = images; + + CHECK_TEAM_INTEGRITY (caf_current_team); + if (count > 0) + { + int *map = caf_current_team->u.image_info->image_map; + int max_id = caf_current_team->u.image_info->image_map_size; + + mapped_images = __builtin_alloca (sizeof (int) * count); + if (!mapped_images) + { + caf_internal_error ("SYNC IMAGES: Can not reserve buffer for mapping " + "images to internal ids. Increase stack size!", + stat, errmsg, errmsg_len); + return; + } + for (int c = 0; c < count; ++c) + { + if (images[c] > 0 && images[c] <= max_id) + { + mapped_images[c] = map[images[c] - 1]; + switch (this_image.supervisor->images[mapped_images[c]].status) + { + case IMAGE_SUCCESS: + caf_internal_error ("SYNC IMAGES: Image %d is stopped", stat, + errmsg, errmsg_len, images[c]); + /* We can come here only, when stat is non-NULL. */ + *stat = CAF_STAT_STOPPED_IMAGE; + return; + case IMAGE_FAILED: + caf_internal_error ("SYNC IMAGES: Image %d has failed", stat, + errmsg, errmsg_len, images[c]); + /* We can come here only, when stat is non-NULL. */ + *stat = CAF_STAT_FAILED_IMAGE; + return; + default: + break; + } + for (int i = 0; i < c; ++i) + if (mapped_images[c] == mapped_images[i]) + { + caf_internal_error ("SYNC IMAGES: Duplicate image %d in " + "images at position %d and &d.", + stat, errmsg, errmsg_len, images[c], + i + 1, c + 1); + /* There is no official error code for this, but 3 is what + OpenCoarray uses. */ + *stat = 3; + return; + } + } + else + { + caf_internal_error ("Invalid image number %d in SYNC IMAGES", + stat, errmsg, errmsg_len, images[c]); + return; + } + } + } + else + HEALTH_CHECK (stat, errmsg, errmsg_len); + + __asm__ __volatile__ ("" ::: "memory"); + sync_table (&local->si, mapped_images, count); + HEALTH_CHECK (stat, errmsg, errmsg_len); +} + +extern void _gfortran_report_exception (void); + +void +_gfortran_caf_stop_numeric (int stop_code, bool quiet) +{ + if (!quiet) + { + _gfortran_report_exception (); + fprintf (stderr, "STOP %d\n", stop_code); + } + exit (stop_code); +} + +void +_gfortran_caf_stop_str (const char *string, size_t len, bool quiet) +{ + if (!quiet) + { + _gfortran_report_exception (); + fputs ("STOP ", stderr); + while (len--) + fputc (*(string++), stderr); + fputs ("\n", stderr); + } + exit (0); +} + + +void +_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet) +{ + if (!quiet) + { + _gfortran_report_exception (); + fputs ("ERROR STOP ", stderr); + while (len--) + fputc (*(string++), stderr); + fputs ("\n", stderr); + } + exit (1); +} + +/* Report that the program terminated because of a fail image issued. */ + +void +_gfortran_caf_fail_image (void) +{ + fputs ("IMAGE FAILED!\n", stderr); + this_image.supervisor->images[this_image.image_num].status = IMAGE_FAILED; + atomic_fetch_add (&this_image.supervisor->failed_images, 1); + exit (0); +} + +/* Get the status of image IMAGE. */ + +int +_gfortran_caf_image_status (int image, caf_team_t *team) +{ + caf_shmem_team_t t = caf_current_team; + int image_index; + + if (team) + t = *(caf_shmem_team_t *) team; + + if (image > t->u.image_info->image_count.count) + return CAF_STAT_STOPPED_IMAGE; + + image_index = t->u.image_info->image_map[image - 1]; + + switch (this_image.supervisor->images[image_index].status) + { + case IMAGE_FAILED: + return CAF_STAT_FAILED_IMAGE; + case IMAGE_SUCCESS: + return CAF_STAT_STOPPED_IMAGE; + + /* When image status is not known, return 0. */ + case IMAGE_OK: + case IMAGE_UNKNOWN: + default: + return 0; + } +} + +static void +stopped_or_failed_images (gfc_descriptor_t *array, caf_team_t *team, int *kind, + image_status img_stat, const char *function_name) +{ + int local_kind = kind != NULL ? *kind : 4; + size_t sti = 0; + caf_shmem_team_t t = caf_current_team; + + if (team) + t = *(caf_shmem_team_t *) team; + + int sz = t->u.image_info->image_map_size; + for (int i = 0; i < sz; ++i) + if (this_image.supervisor->images[t->u.image_info->image_map[i]].status + == img_stat) + ++sti; + + if (sti) + { + array->base_addr = malloc (local_kind * sti); + array->dtype.type = BT_INTEGER; + array->dtype.elem_len = local_kind; + array->dim[0].lower_bound = 1; + array->dim[0]._ubound = sti; + array->dim[0]._stride = 1; + array->span = local_kind; + array->offset = 0; + sti = 0; + for (int i = 0; i < sz; ++i) + if (this_image.supervisor->images[t->u.image_info->image_map[i]].status + == img_stat) + switch (local_kind) + { + case 1: + ((int8_t *) array->base_addr)[sti++] = i + 1; + break; + case 2: + ((int16_t *) array->base_addr)[sti++] = i + 1; + break; + case 4: + ((int32_t *) array->base_addr)[sti++] = i + 1; + break; + case 8: + ((int64_t *) array->base_addr)[sti++] = i + 1; + break; + default: + caf_runtime_error ("Unsupported kind %d in %s.", local_kind, + function_name); + } + } + else + { + array->base_addr = NULL; + array->dtype.type = BT_INTEGER; + array->dtype.elem_len = local_kind; + /* Setting lower_bound higher then upper_bound is what the compiler does + to indicate an empty array. */ + array->dim[0].lower_bound = 0; + array->dim[0]._ubound = -1; + array->dim[0]._stride = 1; + array->offset = 0; + } +} + +void +_gfortran_caf_failed_images (gfc_descriptor_t *array, caf_team_t *team, + int *kind) +{ + stopped_or_failed_images (array, team, kind, IMAGE_FAILED, "FAILED_IMAGES()"); +} + +void +_gfortran_caf_stopped_images (gfc_descriptor_t *array, caf_team_t *team, + int *kind) +{ + stopped_or_failed_images (array, team, kind, IMAGE_SUCCESS, + "STOPPED_IMAGES()"); +} + +void +_gfortran_caf_error_stop (int error, bool quiet) +{ + if (!quiet) + { + _gfortran_report_exception (); + fprintf (stderr, "ERROR STOP %d\n", error); + } + exit (error); +} + +static bool +check_get_team (caf_team_t *team, int *team_number, int *stat, + caf_shmem_team_t *cur_team) +{ + if (team || team_number) + { + *cur_team = caf_current_team; + + if (team) + { + caf_shmem_team_t cand_team = (caf_shmem_team_t) (*team); + while (*cur_team && *cur_team != cand_team) + *cur_team = (*cur_team)->parent; + } + else + while (*cur_team && (*cur_team)->u.image_info->team_id != *team_number) + *cur_team = (*cur_team)->parent; + + if (!*cur_team) + { + if (stat) + { + *stat = 1; + return false; + } + else + caf_runtime_error ("requested team not found"); + } + } + else + *cur_team = caf_current_team; + + CHECK_TEAM_INTEGRITY ((*cur_team)); + return true; +} + +static bool +check_map_team (int *remote_index, int *this_index, const int image_index, + caf_team_t *team, int *team_number, int *stat) +{ + caf_shmem_team_t selected_team; + const bool check = check_get_team (team, team_number, stat, &selected_team); + + if (!selected_team) + return false; +#ifndef NDEBUG + if (image_index < 1 + || image_index > selected_team->u.image_info->image_map_size) + { + if (stat) + *stat = 1; + return false; + } +#endif + + *remote_index = selected_team->u.image_info->image_map[image_index - 1]; + + *this_index = this_image.image_num; + + return check; +} + +void +_gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int mapped_index, this_image_index; + if (stat) + *stat = 0; + + if (!check_map_team (&mapped_index, &this_image_index, source_image, NULL, + NULL, stat)) + return; + + collsub_broadcast_array (desc, mapped_index); +} + +#define GEN_OP(name, op, type) \ + static type name##_##type (type *lhs, type *rhs) { return op (*lhs, *rhs); } + +#define GEN_OP_SERIES(name, op) \ + GEN_OP (name, op, uint8_t) \ + GEN_OP (name, op, uint16_t) \ + GEN_OP (name, op, uint32_t) \ + GEN_OP (name, op, uint64_t) \ + GEN_OP (name, op, int8_t) \ + GEN_OP (name, op, int16_t) \ + GEN_OP (name, op, int32_t) \ + GEN_OP (name, op, int64_t) \ + GEN_OP (name, op, float) \ + GEN_OP (name, op, double) + +#define CO_ADD(l, r) ((l) + (r)) +#define CO_MIN(l, r) ((l) < (r) ? (l) : (r)) +#define CO_MAX(l, r) ((l) > (r) ? (l) : (r)) +GEN_OP_SERIES (sum, CO_ADD) +GEN_OP_SERIES (min, CO_MIN) +GEN_OP_SERIES (max, CO_MAX) + +// typedef void *(*opr_t) (void *, void *); +typedef void *opr_t; + +#define GFC_DESCRIPTOR_KIND(desc) ((desc)->dtype.elem_len) + +#define CASE_TYPE_KIND(name, type, ctype) \ + case type: \ + { \ + switch (GFC_DESCRIPTOR_KIND (desc)) \ + { \ + case 1: \ + opr = (opr_t) name##_##ctype##8_t; \ + break; \ + case 2: \ + opr = (opr_t) name##_##ctype##16_t; \ + break; \ + case 4: \ + opr = (opr_t) name##_##ctype##32_t; \ + break; \ + case 8: \ + opr = (opr_t) name##_##ctype##64_t; \ + break; \ + default: \ + caf_runtime_error ("" #name \ + " not available for type/kind combination"); \ + } \ + break; \ + } + +#define SWITCH_TYPE_KIND(name) \ + switch (GFC_DESCRIPTOR_TYPE (desc)) \ + { \ + CASE_TYPE_KIND (name, BT_INTEGER, int) \ + CASE_TYPE_KIND (name, BT_UNSIGNED, uint) \ + case BT_REAL: \ + switch (GFC_DESCRIPTOR_KIND (desc)) \ + { \ + case 4: \ + opr = (opr_t) name##_float; \ + break; \ + case 8: \ + opr = (opr_t) name##_double; \ + break; \ + default: \ + caf_runtime_error ("" #name \ + " not available for type/kind combination"); \ + } \ + break; \ + default: \ + caf_runtime_error ("" #name " not available for type/kind combination"); \ + } + +void +_gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int mapped_index = -1, this_image_index; + opr_t opr; + + if (stat) + *stat = 0; + + /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */ + if (result_image + && !check_map_team (&mapped_index, &this_image_index, result_image, NULL, + NULL, stat)) + return; + + SWITCH_TYPE_KIND (sum) + + collsub_reduce_array (desc, mapped_index, opr, 0, 0); +} + +void +_gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat, + char *errmsg __attribute__ ((unused)), + int a_len __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int mapped_index = -1, this_image_index; + opr_t opr; + + if (stat) + *stat = 0; + /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */ + if (result_image + && !check_map_team (&mapped_index, &this_image_index, result_image, NULL, + NULL, stat)) + return; + + SWITCH_TYPE_KIND (min) + + collsub_reduce_array (desc, mapped_index, opr, 0, 0); +} + +void +_gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat, + char *errmsg __attribute__ ((unused)), + int a_len __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int mapped_index = -1, this_image_index; + opr_t opr; + + if (stat) + *stat = 0; + /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */ + if (result_image + && !check_map_team (&mapped_index, &this_image_index, result_image, NULL, + NULL, stat)) + return; + + SWITCH_TYPE_KIND (max) + + collsub_reduce_array (desc, mapped_index, opr, 0, 0); +} + +void +_gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *), + int opr_flags, int result_image, int *stat, + char *errmsg __attribute__ ((unused)), int desc_len, + size_t errmsg_len __attribute__ ((unused))) +{ + int mapped_index = -1, this_image_index; + + if (stat) + *stat = 0; + + /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */ + if (result_image + && !check_map_team (&mapped_index, &this_image_index, result_image, NULL, + NULL, stat)) + return; + + collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len); +} + +void +_gfortran_caf_register_accessor (const int hash, getter_t accessor) +{ + if (accessor_hash_table_state == AHT_UNINITIALIZED) + { + aht_cap = 16; + accessor_hash_table = calloc (aht_cap, sizeof (struct accessor_hash_t)); + accessor_hash_table_state = AHT_OPEN; + } + if (aht_size == aht_cap) + { + aht_cap += 16; + accessor_hash_table = realloc (accessor_hash_table, + aht_cap * sizeof (struct accessor_hash_t)); + } + if (accessor_hash_table_state == AHT_PREPARED) + { + accessor_hash_table_state = AHT_OPEN; + } + accessor_hash_table[aht_size].hash = hash; + accessor_hash_table[aht_size].u.getter = accessor; + ++aht_size; +} + +static int +hash_compare (const struct accessor_hash_t *lhs, + const struct accessor_hash_t *rhs) +{ + return lhs->hash < rhs->hash ? -1 : (lhs->hash > rhs->hash ? 1 : 0); +} + +void +_gfortran_caf_register_accessors_finish (void) +{ + if (accessor_hash_table_state == AHT_PREPARED + || accessor_hash_table_state == AHT_UNINITIALIZED) + return; + + qsort (accessor_hash_table, aht_size, sizeof (struct accessor_hash_t), + (int (*) (const void *, const void *)) hash_compare); + accessor_hash_table_state = AHT_PREPARED; +} + +int +_gfortran_caf_get_remote_function_index (const int hash) +{ + if (accessor_hash_table_state != AHT_PREPARED) + { + caf_runtime_error ("the accessor hash table is not prepared."); + } + + struct accessor_hash_t cand; + cand.hash = hash; + struct accessor_hash_t *f + = bsearch (&cand, accessor_hash_table, aht_size, + sizeof (struct accessor_hash_t), + (int (*) (const void *, const void *)) hash_compare); + + int index = f ? f - accessor_hash_table : -1; + return index; +} + +void +_gfortran_caf_get_from_remote ( + caf_token_t token, const gfc_descriptor_t *opt_src_desc, + const size_t *opt_src_charlen, const int image_index, + const size_t dst_size __attribute__ ((unused)), void **dst_data, + size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc, + const bool may_realloc_dst, const int getter_index, void *add_data, + const size_t add_data_size __attribute__ ((unused)), int *stat, + caf_team_t *team, int *team_number) +{ + caf_shmem_token_t shmem_token = TOKEN (token); + void *src_ptr; + int32_t free_buffer; + int remote_image_index, this_image_index; + void *dst_ptr = opt_dst_desc ? (void *)opt_dst_desc : dst_data; + void *old_dst_data_ptr = NULL, *old_src_data_ptr = NULL; + struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false}; + + if (stat) + *stat = 0; + + if (!check_map_team (&remote_image_index, &this_image_index, image_index, + team, team_number, stat)) + return; + + /* Compute the address only after team's mapping has taken place. */ + src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size; + if (opt_src_desc) + { + old_src_data_ptr = opt_src_desc->base_addr; + ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr; + src_ptr = (void *) opt_src_desc; + } + + if (opt_dst_desc && !may_realloc_dst) + { + old_dst_data_ptr = opt_dst_desc->base_addr; + opt_dst_desc->base_addr = NULL; + } + + accessor_hash_table[getter_index].u.getter (add_data, &image_index, dst_ptr, + &free_buffer, src_ptr, &cb_token, + 0, opt_dst_charlen, + opt_src_charlen); + if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst + && opt_dst_desc->base_addr != old_dst_data_ptr) + { + size_t dsize = opt_dst_desc->span; + for (int i = 0; i < GFC_DESCRIPTOR_RANK (opt_dst_desc); ++i) + dsize *= GFC_DESCRIPTOR_EXTENT (opt_dst_desc, i); + memcpy (old_dst_data_ptr, opt_dst_desc->base_addr, dsize); + free (opt_dst_desc->base_addr); + opt_dst_desc->base_addr = old_dst_data_ptr; + } + + if (old_src_data_ptr) + ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr; +} + +int32_t +_gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index, + const int present_index, void *add_data, + const size_t add_data_size + __attribute__ ((unused))) +{ + /* Unregistered tokens are always not present. */ + if (!token) + return 0; + + caf_shmem_token_t shmem_token = TOKEN (token); + int32_t result; + struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false}; + void *src_ptr, *arg; + int remote_image_index, this_image_index; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_desc; + + if (!check_map_team (&remote_image_index, &this_image_index, image_index, + NULL, NULL, NULL)) + return 0; + + src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size; + if (shmem_token->desc) + { + memcpy (&temp_desc, shmem_token->desc, + sizeof (gfc_descriptor_t) + + GFC_DESCRIPTOR_RANK (shmem_token->desc) + * sizeof (descriptor_dimension)); + temp_desc.base_addr = src_ptr; + arg = &temp_desc; + } + else + arg = &src_ptr; + + accessor_hash_table[present_index].u.is_present (add_data, &image_index, + &result, arg, &cb_token, 0); + + return result; +} + +void +_gfortran_caf_send_to_remote ( + caf_token_t token, gfc_descriptor_t *opt_dst_desc, + const size_t *opt_dst_charlen, const int image_index, + const size_t src_size __attribute__ ((unused)), const void *src_data, + const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc, + const int accessor_index, void *add_data, + const size_t add_data_size __attribute__ ((unused)), int *stat, + caf_team_t *team, int *team_number) +{ + caf_shmem_token_t shmem_token = TOKEN (token); + void *dst_ptr, *dst_data_ptr, *old_dst_data_ptr = NULL; + const void *src_ptr = opt_src_desc ? (void *) opt_src_desc : src_data; + struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false}; + int remote_image_index, this_image_index; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_src_desc; + + if (stat) + *stat = 0; + + if (!check_map_team (&remote_image_index, &this_image_index, image_index, + team, team_number, stat)) + return; + + dst_data_ptr = dst_ptr + = shmem_token->base + remote_image_index * shmem_token->image_size; + if (opt_dst_desc) + { + old_dst_data_ptr = opt_dst_desc->base_addr; + ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr; + dst_ptr = (void *) opt_dst_desc; + } + + /* Try to detect copy to self, with overlapping data segment. */ + if (opt_src_desc && remote_image_index == this_image_index) + { + size_t src_data_span = GFC_DESCRIPTOR_SIZE (opt_src_desc); + for (int d = 0; d < GFC_DESCRIPTOR_RANK (opt_src_desc); d++) + src_data_span *= GFC_DESCRIPTOR_EXTENT (opt_src_desc, d); + if (GFC_DESCRIPTOR_DATA (opt_src_desc) >= dst_data_ptr + && dst_data_ptr <= GFC_DESCRIPTOR_DATA (opt_src_desc) + src_data_span) + { + src_ptr = __builtin_alloca (src_data_span); + if (!src_ptr) + { + caf_internal_error ("Out of stack in coarray send (dst[...] = " + "...) expression. Increase stacksize!", + stat, NULL, 0); + return; + } + memcpy ((void *) src_ptr, GFC_DESCRIPTOR_DATA (opt_src_desc), + src_data_span); + memcpy (&temp_src_desc, opt_src_desc, + sizeof (gfc_descriptor_t) + + sizeof (descriptor_dimension) + * GFC_DESCRIPTOR_RANK (opt_src_desc)); + temp_src_desc.base_addr = (void *) src_ptr; + src_ptr = (void *) &temp_src_desc; + } + } + + accessor_hash_table[accessor_index].u.receiver (add_data, &image_index, + dst_ptr, src_ptr, &cb_token, + 0, opt_dst_charlen, + opt_src_charlen); + + if (old_dst_data_ptr) + ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr; +} + +void +_gfortran_caf_transfer_between_remotes ( + caf_token_t dst_token, gfc_descriptor_t *opt_dst_desc, + size_t *opt_dst_charlen, const int dst_image_index, + const int dst_access_index, void *dst_add_data, + const size_t dst_add_data_size __attribute__ ((unused)), + caf_token_t src_token, const gfc_descriptor_t *opt_src_desc, + const size_t *opt_src_charlen, const int src_image_index, + const int src_access_index, void *src_add_data, + const size_t src_add_data_size __attribute__ ((unused)), + const size_t src_size, const bool scalar_transfer, int *dst_stat, + int *src_stat, caf_team_t *dst_team, int *dst_team_number, + caf_team_t *src_team, int *src_team_number) +{ + static const char *out_of_stack_errmsg + = "Out of stack in coarray transfer between remotes (dst[...] = " + "src[...]) expression. Increase stacksize!"; + caf_shmem_token_t src_shmem_token = TOKEN (src_token), + dst_shmem_token = TOKEN (dst_token); + void *src_ptr, *old_src_data_ptr = NULL; + int32_t free_buffer; + void *dst_ptr, *old_dst_data_ptr = NULL; + void *transfer_ptr, *buffer; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) *transfer_desc = NULL; + struct caf_shmem_token cb_token + = {src_add_data, NULL, src_add_data, 0, ~0, false}; + int remote_image_index, this_image_index; + + if (src_stat) + *src_stat = 0; + + if (!check_map_team (&remote_image_index, &this_image_index, src_image_index, + src_team, src_team_number, src_stat)) + return; + + if (!scalar_transfer) + { + const size_t desc_size = sizeof (*transfer_desc); + transfer_desc = __builtin_alloca (desc_size); + if (!transfer_desc) + { + caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0); + return; + } + memset (transfer_desc, 0, desc_size); + transfer_ptr = transfer_desc; + } + else if (opt_dst_charlen) + { + transfer_ptr = __builtin_alloca (*opt_dst_charlen * src_size); + if (!transfer_ptr) + { + caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0); + return; + } + } + else + { + buffer = NULL; + transfer_ptr = &buffer; + } + + src_ptr + = src_shmem_token->base + remote_image_index * src_shmem_token->image_size; + if (opt_src_desc) + { + old_src_data_ptr = opt_src_desc->base_addr; + ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr; + src_ptr = (void *) opt_src_desc; + } + + accessor_hash_table[src_access_index].u.getter ( + src_add_data, &src_image_index, transfer_ptr, &free_buffer, src_ptr, + &cb_token, 0, opt_dst_charlen, opt_src_charlen); + + if (old_src_data_ptr) + ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr; + + if (dst_stat) + *dst_stat = 0; + + if (!check_map_team (&remote_image_index, &this_image_index, dst_image_index, + dst_team, dst_team_number, dst_stat)) + return; + + if (scalar_transfer) + transfer_ptr = *(void **) transfer_ptr; + + dst_ptr + = dst_shmem_token->base + remote_image_index * dst_shmem_token->image_size; + if (opt_dst_desc) + { + old_dst_data_ptr = opt_dst_desc->base_addr; + ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr; + dst_ptr = (void *) opt_dst_desc; + } + + cb_token.memptr = cb_token.base = dst_add_data; + accessor_hash_table[dst_access_index].u.receiver (dst_add_data, + &dst_image_index, dst_ptr, + transfer_ptr, &cb_token, 0, + opt_dst_charlen, + opt_src_charlen); + + if (old_dst_data_ptr) + ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr; + + if (free_buffer) + free (transfer_desc ? transfer_desc->base_addr : transfer_ptr); +} + +#define GET_ATOM \ + caf_shmem_token_t shmem_token = TOKEN (token); \ + int remote_image_index, this_image_index; \ + if (stat) \ + *stat = 0; \ + if (!image_index) \ + image_index = this_image.image_num + 1; \ + if (!check_map_team (&remote_image_index, &this_image_index, image_index, \ + NULL, NULL, stat)) \ + return; \ + assert (kind == 4); \ + uint32_t *atom \ + = (uint32_t *) (shmem_token->base \ + + remote_image_index * shmem_token->image_size + offset) + +void +_gfortran_caf_atomic_define (caf_token_t token, size_t offset, int image_index, + void *value, int *stat, + int type __attribute__ ((unused)), int kind) +{ + GET_ATOM; + + __atomic_store (atom, (uint32_t *) value, __ATOMIC_SEQ_CST); +} + +void +_gfortran_caf_atomic_ref (caf_token_t token, size_t offset, int image_index, + void *value, int *stat, + int type __attribute__ ((unused)), int kind) +{ + GET_ATOM; + + __atomic_load (atom, (uint32_t *) value, __ATOMIC_SEQ_CST); +} + +void +_gfortran_caf_atomic_cas (caf_token_t token, size_t offset, int image_index, + void *old, void *compare, void *new_val, int *stat, + int type __attribute__ ((unused)), int kind) +{ + GET_ATOM; + + *(uint32_t *) old = *(uint32_t *) compare; + (void) __atomic_compare_exchange_n (atom, (uint32_t *) old, + *(uint32_t *) new_val, false, + __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST); +} + +void +_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset, + int image_index, void *value, void *old, int *stat, + int type __attribute__ ((unused)), int kind) +{ + GET_ATOM; + + uint32_t res; + + switch (op) + { + case GFC_CAF_ATOMIC_ADD: + res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST); + break; + case GFC_CAF_ATOMIC_AND: + res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST); + break; + case GFC_CAF_ATOMIC_OR: + res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST); + break; + case GFC_CAF_ATOMIC_XOR: + res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST); + break; + default: + __builtin_unreachable (); + } + + if (old) + *(uint32_t *) old = res; +} + +#define GET_EVENT(token_, index_, image_index_) \ + ((event_t *) (((caf_shmem_token_t) token_)->base \ + + ((caf_shmem_token_t) token_)->image_size * image_index_ \ + + sizeof (event_t) * index_)) + +void +_gfortran_caf_event_post (caf_token_t token, size_t index, int image_index, + int *stat, char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int remote_image_index, this_image_index; + + if (stat) + *stat = 0; + + /* When image_index is zero, access this image's event. */ + if (!image_index) + image_index = this_image.image_num + 1; + + if (!check_map_team (&remote_image_index, &this_image_index, image_index, + NULL, NULL, stat)) + return; + + volatile event_t *event = GET_EVENT (token, index, remote_image_index); + + lock_event (&local->si); + --(*event); + event_post (&local->si); + unlock_event (&local->si); +} + +void +_gfortran_caf_event_wait (caf_token_t token, size_t index, int until_count, + int *stat, char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + int remote_image_index, this_image_index; + + if (stat) + *stat = 0; + + if (!check_map_team (&remote_image_index, &this_image_index, 1, NULL, NULL, + stat)) + return; + + volatile event_t *event = GET_EVENT (token, index, this_image_index); + event_t val; + + lock_event (&local->si); + val = (*event += until_count); + if (val > 0) /* Move the invariant out of the loop. */ + while (*event > 0) + event_wait (&local->si); + unlock_event (&local->si); + + if (stat) + *stat = 0; +} + +void +_gfortran_caf_event_query (caf_token_t token, size_t index, int image_index, + int *count, int *stat) +{ + int remote_image_index, this_image_index; + + if (stat) + *stat = 0; + + /* When image_index is zero, access this image's event. */ + if (!image_index) + image_index = this_image.image_num + 1; + + if (!check_map_team (&remote_image_index, &this_image_index, image_index, + NULL, NULL, stat)) + return; + + volatile event_t *event = GET_EVENT (token, index, remote_image_index); + + lock_event (&local->si); + *count = *event; + unlock_event (&local->si); + + if (*count < 0) + *count = -*count; +} + +void +_gfortran_caf_lock (caf_token_t token, size_t index, + int image_index __attribute__ ((unused)), + int *acquired_lock, int *stat, char *errmsg, + size_t errmsg_len) +{ + const char *msg = "Already locked"; + lock_t *lock = &((lock_t *) MEMTOK (token))[index]; + int res; + + res + = acquired_lock ? pthread_mutex_trylock (lock) : pthread_mutex_lock (lock); + + if (stat) + *stat = res == EBUSY ? GFC_STAT_LOCKED : 0; + + if (acquired_lock) + { + *acquired_lock = (int) (res == 0); + return; + } + + if (!res) + return; + + if (stat) + { + if (errmsg_len > 0) + { + size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len + : sizeof (msg); + memcpy (errmsg, msg, len); + if (errmsg_len > len) + memset (&errmsg[len], ' ', errmsg_len-len); + } + return; + } + _gfortran_caf_error_stop_str (msg, strlen (msg), false); +} + + +void +_gfortran_caf_unlock (caf_token_t token, size_t index, + int image_index __attribute__ ((unused)), + int *stat, char *errmsg, size_t errmsg_len) +{ + const char *msg = "Variable is not locked"; + lock_t *lock = &((lock_t *) MEMTOK (token))[index]; + int res; + + res = pthread_mutex_unlock (lock); + + if (res == 0) + { + if (stat) + *stat = 0; + return; + } + + if (stat && res == EPERM) + { + /* res == EPERM means that the lock is locked. Now figure, if by us by + trying to lock it or by other image, which fails. */ + res = pthread_mutex_trylock (lock); + if (res == EBUSY) + *stat = GFC_STAT_LOCKED_OTHER_IMAGE; + else + { + *stat = GFC_STAT_UNLOCKED; + pthread_mutex_unlock (lock); + } + + if (errmsg_len > 0) + { + size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len + : sizeof (msg); + memcpy (errmsg, msg, len); + if (errmsg_len > len) + memset (&errmsg[len], ' ', errmsg_len-len); + } + return; + } + _gfortran_caf_error_stop_str (msg, strlen (msg), false); +} + + +/* Reference the libraries implementation. */ +extern void _gfortran_random_seed_i4 (int32_t *size, gfc_array_i4 *put, + gfc_array_i4 *get); + +void _gfortran_caf_random_init (bool repeatable, bool image_distinct) +{ + static struct + { + int32_t *base_addr; + size_t offset; + dtype_type dtype; + index_type span; + descriptor_dimension dim[1]; + } rand_seed; + static bool rep_needs_init = true, arr_needs_init = true; + static int32_t seed_size; + + if (arr_needs_init) + { + _gfortran_random_seed_i4 (&seed_size, NULL, NULL); + memset (&rand_seed, 0, + sizeof (gfc_array_i4) + sizeof (descriptor_dimension)); + rand_seed.base_addr + = malloc (seed_size * sizeof (int32_t)); // because using seed_i4 + rand_seed.offset = -1; + rand_seed.dtype.elem_len = sizeof (int32_t); + rand_seed.dtype.rank = 1; + rand_seed.dtype.type = BT_INTEGER; + rand_seed.span = 0; + rand_seed.dim[0].lower_bound = 1; + rand_seed.dim[0]._ubound = seed_size; + rand_seed.dim[0]._stride = 1; + + arr_needs_init = false; + } + + if (repeatable) + { + if (rep_needs_init) + { + int32_t lcg_seed = 57911963; + if (image_distinct) + { + lcg_seed *= this_image.image_num; + } + int32_t *curr = rand_seed.base_addr; + for (int i = 0; i < seed_size; ++i) + { + const int32_t a = 16087; + const int32_t m = INT32_MAX; + const int32_t q = 127773; + const int32_t r = 2836; + lcg_seed = a * (lcg_seed % q) - r * (lcg_seed / q); + if (lcg_seed <= 0) + lcg_seed += m; + *curr = lcg_seed; + ++curr; + } + rep_needs_init = false; + } + _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL); + } + else if (image_distinct) + { + _gfortran_random_seed_i4 (NULL, NULL, NULL); + } + else + { + if (this_image.image_num == 0) + { + _gfortran_random_seed_i4 (NULL, NULL, (gfc_array_i4 *) &rand_seed); + collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0); + } + else + { + collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0); + _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL); + } + } +} + +void +_gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index, + int *stat, char *errmsg, size_t errmsg_len) +{ + const char new_index_out_of_range[] + = "The NEW_INDEX in a FORM TEAM has to in (0, num_images()]."; + const char team_no_negativ[] + = "The team number in FORM TEAM has to be positive."; + const char alloc_fail_msg[] = "Failed to allocate team"; + const char non_unique_image_ids[] + = "The NEW_INDEX of FORM TEAMs has to be unique."; + const char cannot_assign_index[] + = "Can not assign new image index in FORM TEAM."; + static int image_size_shift = -1; + static int teams_count = 0; + caf_shmem_team_t t; + bool created; + memid tmemid; + + if (image_size_shift < 0) + image_size_shift = (int) round (log2 (local->total_num_images)); + if (stat) + *stat = 0; + + CHECK_TEAM_INTEGRITY (caf_current_team); + + if (new_index + && (*new_index <= 0 + || *new_index > caf_current_team->u.image_info->image_count.count)) + { + caf_internal_error (new_index_out_of_range, stat, errmsg, errmsg_len); + return; + } + if (team_no <= 0) + { + caf_internal_error (team_no_negativ, stat, errmsg, errmsg_len); + return; + } + + *team = malloc (sizeof (struct caf_shmem_team)); + if (unlikely (*team == NULL)) + { + caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len); + return; + } + t = *((caf_shmem_team_t *) team); + + allocator_lock (&local->ai.alloc); + if (caf_current_team->team_no == -1) + tmemid = team_no + teams_count; + else + tmemid = (caf_current_team->u.image_info->lastmemid << image_size_shift) + + team_no + teams_count; + ++teams_count; + *t = (struct caf_shmem_team) { + caf_teams_formed, + team_no, + -1, + 0, + NULL, + {alloc_get_memory_by_id_created ( + &local->ai, + sizeof (struct shmem_image_info) + + caf_current_team->u.image_info->image_count.count * sizeof (int), + -tmemid, &created)}}; + + if (created) + { + counter_barrier_init (&t->u.image_info->image_count, 0); + collsub_init_supervisor (&t->u.image_info->collsub, + alloc_get_allocator (&local->ai), 0); + t->u.image_info->team_parent_id = caf_current_team->team_no; + t->u.image_info->team_id = team_no; + t->u.image_info->image_map_size = 0; + t->u.image_info->num_term_images = 0; + t->u.image_info->lastmemid = tmemid; + /* Initialize a freshly created image_map with -1. */ + for (int i = 0; i < caf_current_team->u.image_info->image_count.count; + ++i) + t->u.image_info->image_map[i] = -1; + } + counter_barrier_add (&t->u.image_info->image_count, 1); + counter_barrier_add (&t->u.image_info->collsub.barrier, 1); + allocator_unlock (&local->ai.alloc); + + if (new_index) + { + int old_id; + + t->index = *new_index - 1; + old_id = __atomic_exchange_n (&t->u.image_info->image_map[t->index], + this_image.image_num, __ATOMIC_SEQ_CST); + if (old_id != -1) + { + caf_internal_error (non_unique_image_ids, stat, errmsg, errmsg_len); + return; + } + + __atomic_fetch_add (&t->u.image_info->image_map_size, 1, + __ATOMIC_SEQ_CST); + } + else + { + int im; + int exp = -1; + + __atomic_fetch_add (&t->u.image_info->image_map_size, 1, + __ATOMIC_SEQ_CST); + sync_team (caf_current_team); + + im = caf_current_team->index * t->u.image_info->image_map_size + / caf_current_team->u.image_info->image_count.count; + /* Map our old index into the domain of the new team's size. */ + if (__atomic_compare_exchange_n (&t->u.image_info->image_map[im], &exp, + this_image.image_num, false, + __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST)) + t->index = im; + else + { + caf_internal_error (cannot_assign_index, stat, errmsg, errmsg_len); + return; + } + } + sync_team (caf_current_team); + + caf_teams_formed = t; +} + +void +_gfortran_caf_change_team (caf_team_t team, int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + caf_shmem_team_t t = (caf_shmem_team_t) team; + + if (stat) + *stat = 0; + + if (t == caf_teams_formed) + caf_teams_formed = t->parent; + else + for (caf_shmem_team_t p = caf_teams_formed; p; p = p->parent) + if (p->parent == t) + { + p->parent = t->parent; + break; + } + + t->parent = caf_current_team; + t->parent_teams_last_active_memid = next_memid; + next_memid = (t->u.image_info->team_parent_id != -1 + ? (((memid) t->u.image_info->team_parent_id) << 48) + : 0) + | (((memid) t->u.image_info->team_id) << 32) | 1; + caf_current_team = t; + sync_team (caf_current_team); +} + +void +_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len) +{ + caf_shmem_team_t t = caf_current_team; + + if (stat) + *stat = 0; + + caf_current_team = caf_current_team->parent; + next_memid = t->parent_teams_last_active_memid; + sync_team (t); + + for (struct coarray_allocated *ca = t->allocated; ca;) + { + struct coarray_allocated *nca = ca->next; + _gfortran_caf_deregister ((caf_token_t *) &ca->token, + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, + errmsg, errmsg_len); + free (ca); + ca = nca; + } + t->allocated = NULL; + t->parent = caf_teams_formed; + caf_teams_formed = t; +} + +void +_gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, + size_t errmsg_len) +{ + caf_shmem_team_t team_to_sync = (caf_shmem_team_t) team; + caf_shmem_team_t active_team = caf_current_team; + + if (stat) + *stat = 0; + + /* Check if team to sync is a child of the current team, aka not changed to + yet. */ + if (team_to_sync->u.image_info->team_parent_id != active_team->team_no) + for (; active_team && active_team != team_to_sync; + active_team = active_team->parent) + ; + + CHECK_TEAM_INTEGRITY (active_team); + + if (!active_team) + { + caf_internal_error ("SYNC TEAM: Called on team different from current, " + "or ancestor, or child", + stat, errmsg, errmsg_len); + return; + } + + sync_team (team_to_sync); +} + +int +_gfortran_caf_team_number (caf_team_t team) +{ + return team ? ((caf_shmem_team_t) team)->u.image_info->team_id + : caf_current_team->u.image_info->team_id; +} + +caf_team_t +_gfortran_caf_get_team (int32_t *level) +{ + if (!level) + return caf_current_team; + + switch ((caf_team_level_t) *level) + { + case CAF_INITIAL_TEAM: + return caf_initial_team; + case CAF_PARENT_TEAM: + return caf_current_team->parent ? caf_current_team->parent + : caf_current_team; + case CAF_CURRENT_TEAM: + return caf_current_team; + default: + caf_runtime_error ("Illegal value for GET_TEAM"); + } + return NULL; /* To prevent any warnings. */ +} diff --git a/libgfortran/caf/shmem/alloc.c b/libgfortran/caf/shmem/alloc.c new file mode 100644 index 00000000000..fecf97c03ff --- /dev/null +++ b/libgfortran/caf/shmem/alloc.c @@ -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 +. */ + +/* 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 +#include +#include + +/* 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; +} diff --git a/libgfortran/caf/shmem/alloc.h b/libgfortran/caf/shmem/alloc.h new file mode 100644 index 00000000000..d85b1a30236 --- /dev/null +++ b/libgfortran/caf/shmem/alloc.h @@ -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 +. */ + +#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 diff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c new file mode 100644 index 00000000000..d900167cfc2 --- /dev/null +++ b/libgfortran/caf/shmem/allocator.c @@ -0,0 +1,131 @@ +/* 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 +. */ + +/* Main allocation routine, works like malloc. Round up allocations + to the next power of two and keep free lists in buckets. */ + +#include "libgfortran.h" + +#include "allocator.h" +#include "supervisor.h" +#include "thread_support.h" + +#include + +typedef struct +{ + shared_mem_ptr next; +} bucket; + +size_t +alignto (size_t size, size_t align) +{ + return align * ((size + align - 1) / align); +} + +size_t pagesize; + +size_t +round_to_pagesize (size_t s) +{ + return alignto (s, pagesize); +} + +/* Initialize the allocator. */ + +void +allocator_init (allocator *a, allocator_shared *s, shared_memory sm) +{ + *a = (allocator) {s, sm}; +} + +void +allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm) +{ + *a = (allocator) {s, sm}; + initialize_shared_mutex (&s->lock); + for (size_t i = 0; i < VOIDP_BITS; i++) + s->free_bucket_head[i] = SHMPTR_NULL; +} + +#define MAX_ALIGN 16 + +static size_t +next_power_of_two (size_t size) +{ + assert (size); + return 1 << (VOIDP_BITS - __builtin_clzl (size - 1)); +} + +shared_mem_ptr +allocator_shared_malloc (allocator *a, size_t size) +{ + shared_mem_ptr ret; + size_t sz; + size_t act_size; + int bucket_list_index; + + sz = next_power_of_two (size); + act_size = sz > sizeof (bucket) ? sz : sizeof (bucket); + bucket_list_index = __builtin_clzl (act_size); + + if (SHMPTR_IS_NULL (a->s->free_bucket_head[bucket_list_index])) + return shared_memory_get_mem_with_alignment (a->shm, act_size, MAX_ALIGN); + + ret = a->s->free_bucket_head[bucket_list_index]; + a->s->free_bucket_head[bucket_list_index] + = (SHMPTR_AS (bucket *, ret, a->shm)->next); + return ret; +} + +/* Free memory. */ + +void +allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size) +{ + bucket *b; + size_t sz; + int bucket_list_index; + size_t act_size; + + sz = next_power_of_two (size); + act_size = sz > sizeof (bucket) ? sz : sizeof (bucket); + bucket_list_index = __builtin_clzl (act_size); + + b = SHMPTR_AS (bucket *, p, a->shm); + b->next = a->s->free_bucket_head[bucket_list_index]; + a->s->free_bucket_head[bucket_list_index] = p; +} + +void +allocator_lock (allocator *a) +{ + pthread_mutex_lock (&a->s->lock); +} + +void +allocator_unlock (allocator *a) +{ + pthread_mutex_unlock (&a->s->lock); +} diff --git a/libgfortran/caf/shmem/allocator.h b/libgfortran/caf/shmem/allocator.h new file mode 100644 index 00000000000..53b6abeeba1 --- /dev/null +++ b/libgfortran/caf/shmem/allocator.h @@ -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 +. */ + +/* 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 +#include + +/* The number of bits a void pointer has. */ +#define VOIDP_BITS (__CHAR_BIT__ * sizeof (void *)) + +/* The shared memory part of the allocator. */ +typedef struct { + pthread_mutex_t lock; + shared_mem_ptr free_bucket_head[VOIDP_BITS]; +} allocator_shared; + +/* The image local part of the allocator. */ +typedef struct { + allocator_shared *s; + shared_memory shm; +} allocator; + +/* The size of a page on this architecture. */ +extern size_t pagesize; + +/* Helper routine to align a size to a given boundary. */ +size_t alignto (size_t, size_t); + +/* Helper routine to round a size to multiple of the architecture's pagesize. + */ +size_t round_to_pagesize (size_t); + +/* Link the worker's allocator with the part in the shared memory. */ +void allocator_init (allocator *, allocator_shared *, shared_memory); + +/* Initialize the allocator. This MUST be called ONLY be the supervisor and + only once! */ +void allocator_init_supervisor (allocator *, allocator_shared *, shared_memory); + +/* Request a block of shared memory. The memory is not linked with the other + images. The shared_mem_ptr returned is only local to the calling image. + When requiring a memory block shared between all images, call + alloc_get_memory_by_id...(). */ +shared_mem_ptr allocator_shared_malloc (allocator *, size_t size); + +/* Free the given piece of memory. This routine just inserts the memory chunk + into the bucket list of free memory. It does not join adjacent blocks of + memory (not implemented yet). */ +void allocator_shared_free (allocator *, shared_mem_ptr, size_t size); + +/* Lock the allocator lock preventing any image from modifying memory management + structures. Do not forget to unlock. This interface is exposed to be able + to do more then just get the memory without having to introduce a second lock + and the problems with having to get both. */ +void allocator_lock (allocator *); + +/* Unlock the allocator lock. */ +void allocator_unlock (allocator *); + +#endif diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c new file mode 100644 index 00000000000..257a048d63d --- /dev/null +++ b/libgfortran/caf/shmem/collective_subroutine.c @@ -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 +. */ + +#include "collective_subroutine.h" +#include "supervisor.h" +#include "teams_mgmt.h" +#include "thread_support.h" + +#include + +/* Usage: + pack_info pi; + packed = pack_array_prepare (&pi, source); + + // Awesome allocation of destptr using pi.num_elem + if (packed) + memcpy (...); + else + pack_array_finish (&pi, source, destptr); + +This could also be used in in_pack_generic.c. Additionally, since +pack_array_prepare is the same for all type sizes, we would only have to +specialize pack_array_finish, saving on code size. */ + +typedef struct +{ + index_type num_elem; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type stride[GFC_MAX_DIMENSIONS]; /* Stride is byte-based. */ +} pack_info; + +static bool +pack_array_prepare (pack_info *pi, const gfc_descriptor_t *source) +{ + index_type dim; + bool packed; + index_type span; + index_type type_size; + index_type ssize; + + dim = GFC_DESCRIPTOR_RANK (source); + type_size = GFC_DESCRIPTOR_SIZE (source); + ssize = type_size; + + pi->num_elem = 1; + packed = true; + span = source->span != 0 ? source->span : type_size; + for (index_type n = 0; n < dim; n++) + { + pi->stride[n] = GFC_DESCRIPTOR_STRIDE (source, n) * span; + pi->extent[n] = GFC_DESCRIPTOR_EXTENT (source, n); + if (pi->extent[n] <= 0) + { + /* Do nothing. */ + packed = true; + pi->num_elem = 0; + break; + } + + if (ssize != pi->stride[n]) + packed = false; + + pi->num_elem *= pi->extent[n]; + ssize *= pi->extent[n]; + } + + return packed; +} + +static void +pack_array_finish (const pack_info *pi, const gfc_descriptor_t *source, + char *dest) +{ + index_type dim; + const char *restrict src; + + index_type size; + index_type stride0; + index_type count[GFC_MAX_DIMENSIONS]; + + dim = GFC_DESCRIPTOR_RANK (source); + src = source->base_addr; + stride0 = pi->stride[0]; + size = GFC_DESCRIPTOR_SIZE (source); + memset (count, '\0', sizeof (index_type) * dim); + while (src) + { + /* Copy the data. */ + memcpy (dest, src, size); + /* Advance to the next element. */ + dest += size; + src += stride0; + count[0]++; + /* Advance to the next source element. */ + index_type n = 0; + while (count[n] == pi->extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + src -= pi->stride[n] * pi->extent[n]; + n++; + if (n == dim) + { + src = NULL; + break; + } + else + { + count[n]++; + src += pi->stride[n]; + } + } + } +} + +static void +unpack_array_finish (const pack_info *pi, const gfc_descriptor_t *d, + const void *src) +{ + index_type stride0; + char *restrict dest; + index_type size; + index_type count[GFC_MAX_DIMENSIONS]; + index_type dim; + + size = GFC_DESCRIPTOR_SIZE (d); + stride0 = pi->stride[0]; + dest = d->base_addr; + dim = GFC_DESCRIPTOR_RANK (d); + + memset (count, '\0', sizeof (index_type) * dim); + while (dest) + { + memcpy (dest, src, size); + src += size; + dest += stride0; + count[0]++; + index_type n = 0; + while (count[n] == pi->extent[n]) + { + count[n] = 0; + dest -= pi->stride[n] * pi->extent[n]; + n++; + if (n == dim) + { + dest = NULL; + break; + } + else + { + count[n]++; + dest += pi->stride[n]; + } + } + } +} + +void +collsub_init_supervisor (collsub_shared *cis, allocator *al, + const int init_num_images) +{ + /* Choose an arbitrary large buffer. It can grow later if needed. */ + const size_t init_size = 1U << 10; + + cis->curr_size = init_size; + cis->collsub_buf = allocator_shared_malloc (al, init_size); + + counter_barrier_init (&cis->barrier, init_num_images); + initialize_shared_mutex (&cis->mutex); +} + +static void * +get_collsub_buf (size_t size) +{ + void *ret; + + pthread_mutex_lock (&caf_current_team->u.image_info->collsub.mutex); + /* curr_size is always at least sizeof(double), so we don't need to worry + about size == 0. */ + if (size > caf_current_team->u.image_info->collsub.curr_size) + { + allocator_shared_free ( + alloc_get_allocator (&local->ai), + caf_current_team->u.image_info->collsub.collsub_buf, + caf_current_team->u.image_info->collsub.curr_size); + caf_current_team->u.image_info->collsub.collsub_buf + = allocator_shared_malloc (alloc_get_allocator (&local->ai), size); + caf_current_team->u.image_info->collsub.curr_size = size; + } + + ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf, + &local->sm); + pthread_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex); + return ret; +} + +/* This function syncs all images with one another. It will only return once + all images have called it. */ + +static void +collsub_sync (void) +{ + counter_barrier_wait (&caf_current_team->u.image_info->collsub.barrier); +} + +typedef void *(*red_op) (void *, void *); +typedef void (*ass_op) (red_op, void *, void *, size_t); + +#define GEN_FOR_BITS(BITS) \ + static void assign_##BITS (void *op, uint##BITS##_t *lhs, \ + uint##BITS##_t *rhs, size_t) \ + { \ + *lhs \ + = ((uint##BITS##_t (*) (uint##BITS##_t *, uint##BITS##_t *)) op) (lhs, \ + rhs); \ + } \ + static void assign_by_val_##BITS (void *op, uint##BITS##_t *lhs, \ + uint##BITS##_t *rhs, size_t) \ + { \ + *lhs = ((uint##BITS##_t (*) (uint##BITS##_t, uint##BITS##_t)) op) (*lhs, \ + *rhs); \ + } + +GEN_FOR_BITS (8) +GEN_FOR_BITS (16) +GEN_FOR_BITS (32) +GEN_FOR_BITS (64) +// GEN_FOR_BITS (128) + +static void +assign_float (void *op, float *lhs, float *rhs, size_t) +{ + *lhs = ((float (*) (float *, float *)) op) (lhs, rhs); +} + +static void +assign_double (void *op, double *lhs, double *rhs, size_t) +{ + *lhs = ((double (*) (double *, double *)) op) (lhs, rhs); +} + +static void +assign_var (red_op op, void *lhs, void *rhs, size_t sz) +{ + memcpy (lhs, op (lhs, rhs), sz); +} + +static void +assign_char (void *op, void *lhs, void *rhs, size_t sz) +{ + ((void (*) (char *, size_t, char *, char *, size_t, + size_t)) op) (lhs, sz, lhs, rhs, sz, sz); +} + +static ass_op +gen_reduction (const int type, const size_t sz, const int flags) +{ + const bool by_val = flags & GFC_CAF_ARG_VALUE; + switch (type) + { + case BT_CHARACTER: + return (ass_op) assign_char; + case BT_REAL: + switch (sz) + { + case 4: + return (ass_op) assign_float; + case 8: + return (ass_op) assign_double; + default: + return assign_var; + } + default: + switch (sz) + { + case 1: + return (ass_op) (by_val ? assign_by_val_8 : assign_8); + case 2: + return (ass_op) (by_val ? assign_by_val_16 : assign_16); + case 4: + return (ass_op) (by_val ? assign_by_val_32 : assign_32); + case 8: + return (ass_op) (by_val ? assign_by_val_64 : assign_64); + // case 16: + // return assign_128; + default: + return assign_var; + } + } +} + +/* Having result_image == -1 means allreduce. */ + +void +collsub_reduce_array (gfc_descriptor_t *desc, int result_image, + void *(*op) (void *, void *), int opr_flags, + int str_len __attribute__ ((unused))) +{ + void *buffer; + pack_info pi; + bool packed; + int cbit = 0; + int imoffset; + index_type elem_size; + index_type this_image_size_bytes; + void *this_image_buf, *roll_iter, *src_iter; + ass_op assign; + const int this_img_id = caf_current_team->index; + + packed = pack_array_prepare (&pi, desc); + if (pi.num_elem == 0) + return; + + elem_size = GFC_DESCRIPTOR_SPAN (desc); + this_image_size_bytes = elem_size * pi.num_elem; + + buffer = get_collsub_buf ( + this_image_size_bytes * caf_current_team->u.image_info->image_count.count); + this_image_buf = buffer + this_image_size_bytes * this_img_id; + + if (packed) + memcpy (this_image_buf, GFC_DESCRIPTOR_DATA (desc), this_image_size_bytes); + else + pack_array_finish (&pi, desc, this_image_buf); + + assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags); + collsub_sync (); + + for (; ((this_img_id >> cbit) & 1) == 0 + && (caf_current_team->u.image_info->image_count.count >> cbit) != 0; + cbit++) + { + imoffset = 1 << cbit; + if (this_img_id + imoffset + < caf_current_team->u.image_info->image_count.count) + { + /* Reduce arrays elementwise. */ + roll_iter = this_image_buf; + src_iter = this_image_buf + this_image_size_bytes * imoffset; + for (ssize_t i = 0; i < pi.num_elem; + ++i, roll_iter += elem_size, src_iter += elem_size) + assign (op, roll_iter, src_iter, elem_size); + } + collsub_sync (); + } + for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0; + cbit++) + collsub_sync (); + + if (result_image < 0 || result_image == this_image.image_num) + { + if (packed) + memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, this_image_size_bytes); + else + unpack_array_finish (&pi, desc, buffer); + } + + collsub_sync (); +} + +/* Do not use sync_all(), because the program should deadlock in the case that + * some images are on a sync_all barrier while others are in a collective + * subroutine. */ + +void +collsub_broadcast_array (gfc_descriptor_t *desc, int source_image) +{ + void *buffer; + pack_info pi; + bool packed; + index_type elem_size; + index_type size_bytes; + + packed = pack_array_prepare (&pi, desc); + if (pi.num_elem == 0) + return; + + if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER) + { + if (GFC_DESCRIPTOR_SIZE (desc)) + elem_size = GFC_DESCRIPTOR_SIZE (desc); + else + elem_size = strlen (desc->base_addr); + } + else + elem_size = GFC_DESCRIPTOR_SPAN (desc) != 0 + ? ((index_type) GFC_DESCRIPTOR_SPAN (desc)) + : ((index_type) GFC_DESCRIPTOR_SIZE (desc)); + size_bytes = elem_size * pi.num_elem; + buffer = get_collsub_buf (size_bytes); + + if (source_image == this_image.image_num) + { + if (packed) + memcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes); + else + pack_array_finish (&pi, desc, buffer); + collsub_sync (); + } + else + { + collsub_sync (); + if (packed) + memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes); + else + unpack_array_finish (&pi, desc, buffer); + } + + collsub_sync (); +} diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h new file mode 100644 index 00000000000..8c37186c867 --- /dev/null +++ b/libgfortran/caf/shmem/collective_subroutine.h @@ -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 +. */ + +#ifndef COLLECTIVE_SUBROUTINE_HDR +#define COLLECTIVE_SUBROUTINE_HDR + +#include "alloc.h" +#include "counter_barrier.h" +#include "shared_memory.h" + +#include "caf/libcaf.h" + +typedef struct collsub_shared +{ + size_t curr_size; + shared_mem_ptr collsub_buf; + counter_barrier barrier; + pthread_mutex_t mutex; +} collsub_shared; + +void collsub_init_supervisor (collsub_shared *, allocator *, + const int init_num_images); + +void collsub_broadcast_array (gfc_descriptor_t *, int); + +void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *), + int opr_flags, int str_len); + +#endif diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c new file mode 100644 index 00000000000..f78ba7fe852 --- /dev/null +++ b/libgfortran/caf/shmem/counter_barrier.c @@ -0,0 +1,121 @@ +/* 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 +. */ + +#include "libgfortran.h" +#include "counter_barrier.h" +#include "supervisor.h" +#include "thread_support.h" + +#include + +/* Lock the associated counter of this barrier. */ + +static inline void +lock_counter_barrier (counter_barrier *b) +{ + pthread_mutex_lock (&b->mutex); +} + +/* Unlock the associated counter of this barrier. */ + +static inline void +unlock_counter_barrier (counter_barrier *b) +{ + pthread_mutex_unlock (&b->mutex); +} + +void +counter_barrier_init (counter_barrier *b, int val) +{ + *b = (counter_barrier) {PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER, + val, 0, val}; + initialize_shared_condition (&b->cond); + initialize_shared_mutex (&b->mutex); +} + +void +counter_barrier_wait (counter_barrier *b) +{ + int wait_group_beginning; + + lock_counter_barrier (b); + + wait_group_beginning = b->curr_wait_group; + + if ((--b->wait_count) <= 0) + pthread_cond_broadcast (&b->cond); + else + { + while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning) + pthread_cond_wait (&b->cond, &b->mutex); + } + + if (b->wait_count <= 0) + { + b->curr_wait_group = !wait_group_beginning; + b->wait_count = b->count; + } + + unlock_counter_barrier (b); +} + + +static inline void +change_internal_barrier_count (counter_barrier *b, int val) +{ + b->wait_count += val; + if (b->wait_count <= 0) + pthread_cond_broadcast (&b->cond); +} + +int +counter_barrier_add_locked (counter_barrier *c, int val) +{ + int ret; + ret = (c->count += val); + change_internal_barrier_count (c, val); + + return ret; +} + +int +counter_barrier_add (counter_barrier *c, int val) +{ + int ret; + pthread_mutex_lock (&c->mutex); + ret = counter_barrier_add_locked (c, val); + + pthread_mutex_unlock (&c->mutex); + return ret; +} + +int +counter_barrier_get_count (counter_barrier *c) +{ + int ret; + pthread_mutex_lock (&c->mutex); + ret = c->count; + pthread_mutex_unlock (&c->mutex); + return ret; +} diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h new file mode 100644 index 00000000000..a28c58812a5 --- /dev/null +++ b/libgfortran/caf/shmem/counter_barrier.h @@ -0,0 +1,76 @@ +/* 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 +. */ + +#ifndef COUNTER_BARRIER_HDR +#define COUNTER_BARRIER_HDR + +#include + +/* Usable as counter barrier and as waitable counter. + This "class" allows to sync all images acting as a barrier. For this the + counter_barrier is to be initialized by the number of images and then later + calls to counter_barrier_wait() will sync the given number of images. There + is no order in which the images will be woken up from their wait. + Furthermore may this "class" be used as a event queue counter. To use it in + that way the counter barrier is to be initialized with zero. Every "add" to + the queue then is to be made by incrementing the counter_barrier every take + by decrementing the queue. If the queue does not satiesfy the needed number + of entries they can be waited for. + */ + +typedef struct +{ + pthread_mutex_t mutex; + pthread_cond_t cond; + volatile int wait_count; + volatile int curr_wait_group; + volatile int count; +} counter_barrier; + +/* Initialize the counter barrier. Only to be called once per counter barrier. + I.e. a counter barrier in shared memory must only be initialized by one + image. */ + +void counter_barrier_init (counter_barrier *, int); + +/* Add the given number to the counter barrier. This signals waiting images + when the count drops below 0. This routine is only to be called, when the + image has taken the counter barrier's lock by some other way. */ + +int counter_barrier_add_locked (counter_barrier *, int); + +/* Add the given number to the counter barrier. This signals waiting images + when the count drops below 0. */ + +int counter_barrier_add (counter_barrier *, int); + +/* Get the count of the barrier. */ + +int counter_barrier_get_count (counter_barrier *); + +/* Wait for the count in the barrier drop to or below 0. */ + +void counter_barrier_wait (counter_barrier *); + +#endif diff --git a/libgfortran/caf/shmem/hashmap.c b/libgfortran/caf/shmem/hashmap.c new file mode 100644 index 00000000000..e17d6dd2dca --- /dev/null +++ b/libgfortran/caf/shmem/hashmap.c @@ -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 +. */ + +#include "libgfortran.h" + +#include "hashmap.h" + +#include + +#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); +} diff --git a/libgfortran/caf/shmem/hashmap.h b/libgfortran/caf/shmem/hashmap.h new file mode 100644 index 00000000000..bc263d32dcd --- /dev/null +++ b/libgfortran/caf/shmem/hashmap.h @@ -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 +. */ + +#ifndef HASHMAP_H +#define HASHMAP_H + +#include "allocator.h" + +#include +#include +#include + +/* 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 diff --git a/libgfortran/caf/shmem/shared_memory.c b/libgfortran/caf/shmem/shared_memory.c new file mode 100644 index 00000000000..2b3666ddd3b --- /dev/null +++ b/libgfortran/caf/shmem/shared_memory.c @@ -0,0 +1,200 @@ +/* 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 +. */ + +#include "libgfortran.h" +#include "allocator.h" +#include "shared_memory.h" + +#include +#include +#include +#include +#include +#include + +/* This implements shared memory based on POSIX mmap. We start with + memory block of the size of the global shared memory data, rounded + up to one pagesize, and enlarge as needed. + + We address the memory via a shared_memory_ptr, which is an offset into + the shared memory block. The metadata is situated at offset 0. + + In order to be able to resize the memory and to keep pointers + valid, we keep the old mapping around, so the memory is actually + visible several times to the process. Thus, pointers returned by + shared_memory_get_mem_with_alignment remain valid even when + resizing. */ + +static const char *ENV_PPID = "GFORTRAN_SHMEM_PPID"; +static const char *ENV_BASE = "GFORTRAN_SHMEM_BASE"; + +void +shared_memory_set_env (pid_t pid) +{ +#define bufsize 20 + char buffer[bufsize]; + + snprintf (buffer, bufsize, "%d", pid); + setenv (ENV_PPID, buffer, 1); +#undef bufsize +} + +char * +shared_memory_get_env (void) +{ + return getenv (ENV_PPID); +} + +/* Get a pointer into the shared memory block with alignemnt + (works similar to sbrk). */ + +shared_mem_ptr +shared_memory_get_mem_with_alignment (shared_memory_act *mem, size_t size, + size_t align) +{ + size_t aligned_curr_size = alignto (mem->glbl.meta->used, align); + mem->glbl.meta->used = aligned_curr_size + size; + return (shared_mem_ptr) {aligned_curr_size}; +} + +shared_mem_ptr +shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align) +{ + if (mem->glbl.meta->master) + return (shared_mem_ptr) {mem->glbl.meta->master}; + else + { + ptrdiff_t loc = mem->glbl.meta->used; + shared_mem_ptr p + = shared_memory_get_mem_with_alignment (mem, size, align); + mem->glbl.meta->master = loc; + return p; + } +} + +/* If another image changed the size, update the size accordingly. */ + +void +shared_memory_prepare (shared_memory_act *) +{ + asm volatile ("" ::: "memory"); +} + +#define NAME_MAX 255 + +/* Initialize the memory with one page, the shared metadata of the + shared memory is stored at the beginning. */ + +void +shared_memory_init (shared_memory_act *mem, size_t size) +{ + char shm_name[NAME_MAX]; + const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE); + pid_t ppid = getpid (); + int shm_fd, res; + void *base_ptr; + + if (env_val) + { + int n = sscanf (env_val, "%d", &ppid); + assert (n == 1); + } + snprintf (shm_name, NAME_MAX, "/gfor-shm-%d", ppid); + if (base) + { + int n = sscanf (base, "%p", &base_ptr); + assert (n == 1); + } + else + base_ptr = NULL; + + if (!env_val) + { + shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600); + if (shm_fd == -1) + { + perror ("creating shared memory segment failed."); + exit (1); + } + + res = ftruncate (shm_fd, size); + if (res == -1) + { + perror ("resizing shared memory segment failed."); + exit (1); + } + } + else + { + shm_fd = shm_open (shm_name, O_RDWR, 0); + if (shm_fd == -1) + { + perror ("opening shared memory segment failed."); + exit (1); + } + } + + mem->glbl.base + = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, shm_fd, 0); + res = close (shm_fd); + if (mem->glbl.base == MAP_FAILED) + { + perror ("mmap failed"); + exit (1); + } + if (!base_ptr) + { +#define bufsize 20 + char buffer[bufsize]; + + snprintf (buffer, bufsize, "%p", mem->glbl.base); + setenv (ENV_BASE, buffer, 1); +#undef bufsize + } + if (res) + { // from close() + perror ("closing shm file handle failed. Trying to continue..."); + } + mem->size = size; + if (!env_val) + *mem->glbl.meta + = (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0}; + +} + +void +shared_memory_cleanup (shared_memory_act *) +{ + char shm_name[NAME_MAX]; + int res; + + snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ()); + res = shm_unlink (shm_name); + if (res == -1) + { + perror ("shm_unlink failed"); + exit (1); + } +} +#undef NAME_MAX diff --git a/libgfortran/caf/shmem/shared_memory.h b/libgfortran/caf/shmem/shared_memory.h new file mode 100644 index 00000000000..01ac2811e5d --- /dev/null +++ b/libgfortran/caf/shmem/shared_memory.h @@ -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 +. */ + +#ifndef SHARED_MEMORY_H +#define SHARED_MEMORY_H + +#include +#include +#include + +/* Global metadata for shared memory, always kept at offset 0. */ + +typedef struct +{ + size_t used; + ptrdiff_t master; +} global_shared_memory_meta; + +/* Type realization for shared_memory. */ + +typedef struct shared_memory_act +{ + union + { + void *base; + global_shared_memory_meta *meta; + } glbl; + size_t size; // const +} shared_memory_act; + +/* A struct to serve as shared memory object. */ + +typedef struct shared_memory_act * shared_memory; + +#define SHMPTR_NULL ((shared_mem_ptr) {.offset = 0}) +#define SHMPTR_IS_NULL(x) (x.offset == 0) + +#define SHMPTR_DEREF(x, s, sm) ((x) = *(__typeof (x) *) s.p) +#define SHMPTR_AS(type, s, sm) ((type) (*((void **) sm) + s.offset)) +#define AS_SHMPTR(p, sm) ((shared_mem_ptr) {.offset = (p) - sm.glbl.base}) + +#define SHARED_MEMORY_RAW_ALLOC(mem, t, n) \ + shared_memory_get_mem_with_alignment (mem, sizeof (t) * n, __alignof__ (t)) + +#define SHARED_MEMORY_RAW_ALLOC_PTR(mem, t) \ + SHMPTR_AS (t *, SHARED_MEMORY_RAW_ALLOC (mem, t, 1), mem) + +/* A shared-memory pointer is implemented as an offset into the shared + memory region. */ + +typedef struct shared_mem_ptr +{ + ptrdiff_t offset; +} shared_mem_ptr; + +void shared_memory_init (shared_memory, size_t); + +void shared_memory_cleanup (shared_memory); + +void shared_memory_prepare (shared_memory); + +shared_mem_ptr shared_memory_get_mem_with_alignment (shared_memory mem, + size_t size, size_t align); + +shared_mem_ptr shared_memory_get_master (shared_memory pmem, size_t size, + size_t align); + +void shared_memory_set_env (pid_t pid); + +char *shared_memory_get_env (void); + +#endif diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c new file mode 100644 index 00000000000..9e5b794a23f --- /dev/null +++ b/libgfortran/caf/shmem/supervisor.c @@ -0,0 +1,311 @@ +/* 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 +. */ + +#include "config.h" + +#include "../caf_error.h" +#include "supervisor.h" +#include "teams_mgmt.h" +#include "thread_support.h" + +#include +#include +#include +#ifdef HAVE_WAIT_H +#include +#elif HAVE_SYS_WAIT_H +#include +#endif + +#define GFORTRAN_ENV_NUM_IMAGES "GFORTRAN_NUM_IMAGES" +#define GFORTRAN_ENV_SHARED_MEMORY_SIZE "GFORTRAN_SHARED_MEMORY_SIZE" +#define GFORTRAN_ENV_IMAGE_NUM "GFORTRAN_IMAGE_NUM" + +image_local *local = NULL; + +image this_image = {-1, NULL}; + +/* Get image number from environment or sysconf. */ + +static int +get_image_num_from_envvar (void) +{ + char *num_images_char; + int nimages; + num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES); + if (!num_images_char) + return sysconf (_SC_NPROCESSORS_ONLN); /* TODO: Make portable. */ + /* TODO: Error checking. */ + nimages = atoi (num_images_char); + return nimages; +} + +/* Get the amount of memory for the shared memory block. This is picked from + an environment variable. If that is not there, pick a reasonable default. + Note that on a 64-bit system which allows overcommit, there is no penalty in + reserving a large space and then not using it. */ + +static size_t +get_memory_size_from_envvar (void) +{ + char *e; + size_t sz = 0; + e = getenv (GFORTRAN_ENV_SHARED_MEMORY_SIZE); + if (e) + { + char suffix[2]; + int rv; + rv = sscanf (e, "%zu%1s", &sz, suffix); + if (rv == 2) + { + switch (suffix[0]) + { + case 'k': + case 'K': + sz *= ((size_t) 1) << 10; + break; + case 'm': + case 'M': + sz *= ((size_t) 1) << 20; + break; + case 'g': + case 'G': + sz *= ((size_t) 1) << 30; + break; + default: + sz = 0; + } + } + } + if (sz == 0) + { + /* Use 256 MB for 32-bit systems and 4 GB for 64-bit systems. */ + if (sizeof (size_t) == 4) + sz = ((size_t) 1) << 28; + else + sz = ((size_t) 1) << 34; + } + return sz; +} + +/* Get a supervisor. */ + +static supervisor * +get_supervisor (void) +{ + supervisor *sv; + sv = SHMPTR_AS (supervisor *, + shared_memory_get_master (&local->sm, + sizeof (supervisor) + + sizeof (image_tracker) + * local->total_num_images, + __alignof__ (supervisor)), + &local->sm); + sv->failed_images = 0; + sv->finished_images = 0; + return sv; +} + +/* Defined in shmem.c, but we need it here. */ + +extern memid next_memid; + +#define SUPERVISOR_MAGIC_NUM 0x12345678 + +/* Ensure things are initialized. */ + +void +ensure_shmem_initialization (void) +{ + size_t shmem_size; + char *image_num; + + if (local) + return; + + local = malloc (sizeof (image_local)); + pagesize = sysconf (_SC_PAGE_SIZE); + shmem_size = round_to_pagesize (get_memory_size_from_envvar ()); + local->total_num_images = get_image_num_from_envvar (); + shared_memory_init (&local->sm, shmem_size); + shared_memory_prepare (&local->sm); + + /* Shared memory needs to be present, before master can be initialized/linked + to. */ + image_num = getenv (GFORTRAN_ENV_IMAGE_NUM); + if (image_num) + { + bool created; + this_image = (image) {atoi (image_num), get_supervisor ()}; + assert (this_image.supervisor->magic_number == SUPERVISOR_MAGIC_NUM); + + alloc_init (&local->ai, &local->sm); + + caf_initial_team = caf_current_team + = (caf_shmem_team_t) calloc (1, sizeof (struct caf_shmem_team)); + allocator_lock (&local->ai.alloc); + *caf_initial_team = (struct caf_shmem_team) { + NULL, + -1, + this_image.image_num, + 0, + NULL, + {alloc_get_memory_by_id_created (&local->ai, + local->total_num_images * sizeof (int) + + sizeof (struct shmem_image_info), + next_memid++, &created)}}; + if (created) + { + counter_barrier_init (&caf_initial_team->u.image_info->image_count, + local->total_num_images); + collsub_init_supervisor (&caf_initial_team->u.image_info->collsub, + alloc_get_allocator (&local->ai), + local->total_num_images); + caf_initial_team->u.image_info->team_parent_id = 0; + caf_initial_team->u.image_info->team_id = -1; + caf_initial_team->u.image_info->image_map_size + = local->total_num_images; + caf_initial_team->u.image_info->num_term_images = 0; + caf_initial_team->u.image_info->lastmemid = 0; + for (int i = 0; i < local->total_num_images; ++i) + caf_initial_team->u.image_info->image_map[i] = i; + } + allocator_unlock (&local->ai.alloc); + sync_init (&local->si, &local->sm); + } + else + { + this_image = (image) {-1, get_supervisor ()}; + this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM; + counter_barrier_init (&this_image.supervisor->num_active_images, + local->total_num_images); + alloc_init_supervisor (&local->ai, &local->sm); + sync_init_supervisor (&local->si, &local->ai); + } +} + +extern char **environ; + +int +supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv, + int *exit_code) +{ + supervisor *m; + pid_t new_pid, finished_pid; + image im; + int chstatus; + + *exit_code = 0; + shared_memory_set_env (getpid ()); + m = this_image.supervisor; + + for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++) + { + if ((new_pid = fork ())) + { + if (new_pid == -1) + caf_runtime_error ("error spawning child\n"); + m->images[im.image_num] = (image_tracker) {new_pid, IMAGE_OK}; + } + else + { + static char **new_env; + static char num_image[32]; + size_t n = 2; /* Add one env-var and one for the term NULL. */ + + /* Count the number of entries in the current environment. */ + for (char **e = environ; *e; ++e, ++n) + ; + new_env = (char **) malloc (sizeof (char *) * n); + memcpy (new_env, environ, sizeof (char *) * (n - 2)); + snprintf (num_image, 32, "%s=%d", GFORTRAN_ENV_IMAGE_NUM, + im.image_num); + new_env[n - 2] = num_image; + new_env[n - 1] = NULL; + execve ((*argv)[0], *argv, new_env); + return 1; + } + } + for (int j, i = 0; i < local->total_num_images; i++) + { + finished_pid = wait (&chstatus); + if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus)) + { + for (j = 0; + j < local->total_num_images && m->images[j].pid != finished_pid; + j++) + ; + /* Only set the status, when it has not been set by the (failing) + image already. */ + if (m->images[j].status == IMAGE_OK) + { + m->images[j].status = IMAGE_SUCCESS; + atomic_fetch_add (&m->finished_images, 1); + } + } + else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus)) + { + for (j = 0; + j < local->total_num_images && m->images[j].pid != finished_pid; + j++) + ; + dprintf (2, "ERROR: Image %d(pid: %d) failed with %d.\n", j + 1, + finished_pid, WTERMSIG (chstatus)); + if (j == local->total_num_images) + { + if (finished_pid == getpid ()) + { + dprintf (2, + "WARNING: Supervisor process got signal %d. Killing " + "childs and exiting.\n", + WTERMSIG (chstatus)); + for (j = 0; j < local->total_num_images; j++) + { + if (m->images[j].status == IMAGE_OK) + kill (m->images[j].pid, SIGKILL); + } + exit (1); + } + dprintf (2, + "WARNING: Got signal %d for unknown process %d. " + "Ignoring and trying to continue.\n", + WTERMSIG (chstatus), finished_pid); + continue; + } + m->images[j].status = IMAGE_FAILED; + atomic_fetch_add (&m->failed_images, 1); + if (*exit_code < WTERMSIG (chstatus)) + *exit_code = WTERMSIG (chstatus); + else if (*exit_code == 0) + *exit_code = 1; + } + /* Trigger waiting sync images aka sync_table. */ + for (j = 0; j < local->total_num_images; j++) + pthread_cond_signal (&SHMPTR_AS (pthread_cond_t *, + m->sync_shared.sync_images_cond_vars, + &local->sm)[j]); + counter_barrier_add (&m->num_active_images, -1); + } + return 0; +} diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h new file mode 100644 index 00000000000..7afb8269674 --- /dev/null +++ b/libgfortran/caf/shmem/supervisor.h @@ -0,0 +1,112 @@ +/* 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 +. */ + +#ifndef SUPERVISOR_H +#define SUPERVISOR_H + +#include "caf/libcaf.h" +#include "alloc.h" +#include "collective_subroutine.h" +#include "sync.h" + +#include + +typedef enum +{ + IMAGE_UNKNOWN = 0, + IMAGE_OK, + IMAGE_FAILED, + IMAGE_SUCCESS +} image_status; + +typedef struct +{ + pid_t pid; + image_status status; +} image_tracker; + +typedef struct supervisor +{ + ptrdiff_t magic_number; + alloc_shared alloc_shared; + hashmap_shared hms; + collsub_shared collsub_shared; + sync_shared sync_shared; + atomic_int failed_images; + atomic_int finished_images; + counter_barrier num_active_images; + pthread_mutex_t image_tracker_lock; + image_tracker images[]; +} supervisor; + +typedef struct +{ + int image_num; + supervisor *supervisor; +} image; + +extern image this_image; + +typedef struct +{ + int total_num_images; + struct shared_memory_act sm; + alloc ai; + sync_t si; +} image_local; + +extern image_local *local; + +struct caf_shmem_token +{ + /* The pointer to the memory registered for the current image. For arrays + this is the data member in the descriptor. For components it's the pure + data pointer. */ + void *memptr; + /* The descriptor when this token is associated to an allocatable array. */ + gfc_descriptor_t *desc; + /* The base address this coarray's memory in the shared memory space. The + base address of image I is computed by base + I * image_size. */ + void *base; + /* The size of memory in each image aligned on pointer borders, i.e. each + images memory starts on an address that is aligned to enable maximum speed + for the processor architecure used. */ + size_t image_size; + /* The id of this token. */ + memid token_id; + /* Set when the caf lib has allocated the memory in memptr and is responsible + for freeing it on deregister. */ + bool owning_memory; +}; +typedef struct caf_shmem_token *caf_shmem_token_t; + + +/* Ensure the shared memory environment is up and all support structures are + initialized and linked correctly. */ + +void ensure_shmem_initialization (void); + +int supervisor_main_loop (int *argc, char ***argv, int *exit_code); + +#endif diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c new file mode 100644 index 00000000000..a456244629c --- /dev/null +++ b/libgfortran/caf/shmem/sync.c @@ -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 +. */ + +#include "libgfortran.h" +#include "supervisor.h" +#include "sync.h" +#include "teams_mgmt.h" +#include "thread_support.h" + +#include + +static inline void +lock_table (sync_t *si) +{ + pthread_mutex_lock (&si->cis->sync_images_table_lock); +} + +static inline void +unlock_table (sync_t *si) +{ + pthread_mutex_unlock (&si->cis->sync_images_table_lock); +} + +void +sync_init (sync_t *si, shared_memory sm) +{ + *si = (sync_t) { + &this_image.supervisor->sync_shared, + SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm), + SHMPTR_AS (pthread_cond_t *, + this_image.supervisor->sync_shared.sync_images_cond_vars, sm)}; +} + +void +sync_init_supervisor (sync_t *si, alloc *ai) +{ + const int num_images = local->total_num_images; + const size_t table_size_in_bytes = sizeof (int) * num_images * num_images; + + si->cis = &this_image.supervisor->sync_shared; + + initialize_shared_mutex (&si->cis->event_lock); + initialize_shared_condition (&si->cis->event_cond); + + initialize_shared_mutex (&si->cis->sync_images_table_lock); + + si->cis->sync_images_table + = allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes); + si->cis->sync_images_cond_vars + = allocator_shared_malloc (alloc_get_allocator (ai), + sizeof (pthread_cond_t) * num_images); + + si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem); + si->triggers + = SHMPTR_AS (pthread_cond_t *, si->cis->sync_images_cond_vars, ai->mem); + + for (int i = 0; i < num_images; i++) + initialize_shared_condition (&si->triggers[i]); + + memset (si->table, 0, table_size_in_bytes); +} + +void +sync_table (sync_t *si, int *images, int size) +{ + /* The variable `table` is an N x N matrix, where N is the number of all + images. The position (i, j) (where i and j are always the real images + index, i.e. after team de-mapping) tells whether image i has seen the same + number of synchronisation calls to sync_table like j. When table(i,j) == + table(j,i) then the sync for i with this image is completed (here j is the + real image index of the current image). When this holds for all i in the + current set of images (or all images, if the set is empty), then sync table + command is completed. + */ + volatile int *table = si->table; + int i; + + lock_table (si); + if (size > 0) + { + const size_t img_c = caf_current_team->u.image_info->image_map_size; + for (i = 0; i < size; ++i) + { + ++table[images[i] + img_c * this_image.image_num]; + pthread_cond_signal (&si->triggers[images[i]]); + } + for (;;) + { + for (i = 0; i < size; ++i) + if (this_image.supervisor->images[images[i]].status == IMAGE_OK + && table[images[i] + this_image.image_num * img_c] + > table[this_image.image_num + images[i] * img_c]) + break; + if (i == size) + break; + pthread_cond_wait (&si->triggers[this_image.image_num], + &si->cis->sync_images_table_lock); + } + } + else + { + int *map = caf_current_team->u.image_info->image_map; + size = caf_current_team->u.image_info->image_count.count; + for (i = 0; i < size; ++i) + { + if (this_image.supervisor->images[map[i]].status != IMAGE_OK) + continue; + ++table[map[i] + size * this_image.image_num]; + pthread_cond_signal (&si->triggers[map[i]]); + } + for (;;) + { + for (i = 0; i < size; ++i) + if (this_image.supervisor->images[map[i]].status == IMAGE_OK + && table[map[i] + size * this_image.image_num] + > table[this_image.image_num + map[i] * size]) + break; + if (i == size) + break; + pthread_cond_wait (&si->triggers[this_image.image_num], + &si->cis->sync_images_table_lock); + } + } + unlock_table (si); +} + +void +sync_all (void) +{ + counter_barrier_wait (&caf_current_team->u.image_info->image_count); +} + +void +sync_team (caf_shmem_team_t team) +{ + counter_barrier_wait (&team->u.image_info->image_count); +} + +void +lock_event (sync_t *si) +{ + pthread_mutex_lock (&si->cis->event_lock); +} + +void +unlock_event (sync_t *si) +{ + pthread_mutex_unlock (&si->cis->event_lock); +} + +void +event_post (sync_t *si) +{ + pthread_cond_broadcast (&si->cis->event_cond); +} + +void +event_wait (sync_t *si) +{ + pthread_cond_wait (&si->cis->event_cond, &si->cis->event_lock); +} diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h new file mode 100644 index 00000000000..a3e586bca24 --- /dev/null +++ b/libgfortran/caf/shmem/sync.h @@ -0,0 +1,79 @@ +/* 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 +. */ + +#ifndef SYNC_H +#define SYNC_H + +#include "alloc.h" +#include "counter_barrier.h" + +#include + +typedef struct { + /* Mutex and condition variable needed for signaling events. */ + pthread_mutex_t event_lock; + pthread_cond_t event_cond; + pthread_mutex_t sync_images_table_lock; + shared_mem_ptr sync_images_table; + shared_mem_ptr sync_images_cond_vars; +} sync_shared; + +typedef struct { + sync_shared *cis; + int *table; // we can cache the table and the trigger pointers here + pthread_cond_t *triggers; +} sync_t; + +typedef pthread_mutex_t lock_t; + +typedef int event_t; + +void sync_init (sync_t *, shared_memory); + +void sync_init_supervisor (sync_t *, alloc *); + +void sync_all (void); + +/* Prototype for circular dependency break. */ + +struct caf_shmem_team; +typedef struct caf_shmem_team *caf_shmem_team_t; + +void sync_team (caf_shmem_team_t team); + +void sync_table (sync_t *, int *, int); + +void lock_alloc_lock (sync_t *); + +void unlock_alloc_lock (sync_t *); + +void lock_event (sync_t *); + +void unlock_event (sync_t *); + +void event_post (sync_t *); + +void event_wait (sync_t *); + +#endif diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c new file mode 100644 index 00000000000..44a34d727c3 --- /dev/null +++ b/libgfortran/caf/shmem/teams_mgmt.c @@ -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 +. */ + +#include "teams_mgmt.h" +#include "../caf_error.h" + +caf_shmem_team_t caf_current_team = NULL, caf_initial_team; +caf_shmem_team_t caf_teams_formed = NULL; + +void +update_teams_images (caf_shmem_team_t team) +{ + pthread_mutex_lock (&team->u.image_info->image_count.mutex); + if (team->u.image_info->num_term_images + != this_image.supervisor->finished_images + + this_image.supervisor->failed_images) + { + const int old_num = team->u.image_info->num_term_images; + const int sz = team->u.image_info->image_map_size; + int i, good = 0; + + for (i = 0; i < sz; ++i) + if (this_image.supervisor->images[team->u.image_info->image_map[i]] + .status + == IMAGE_OK) + ++good; + + team->u.image_info->num_term_images = sz - good; + + counter_barrier_add_locked (&team->u.image_info->image_count, + old_num + - team->u.image_info->num_term_images); + } + pthread_mutex_unlock (&team->u.image_info->image_count.mutex); +} + +void +check_health (int *stat, char *errmsg, size_t errmsg_len) +{ + if (this_image.supervisor->finished_images + || this_image.supervisor->failed_images) + { + if (this_image.supervisor->finished_images) + { + caf_internal_error ("Stopped images present (currently %d)", stat, + errmsg, errmsg_len, + this_image.supervisor->finished_images); + if (stat) + *stat = CAF_STAT_STOPPED_IMAGE; + } + else if (this_image.supervisor->failed_images) + { + caf_internal_error ("Failed images present (currently %d)", stat, + errmsg, errmsg_len, + this_image.supervisor->failed_images); + if (stat) + *stat = CAF_STAT_FAILED_IMAGE; + } + } + else if (stat) + *stat = 0; +} diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h new file mode 100644 index 00000000000..f96f4aea33e --- /dev/null +++ b/libgfortran/caf/shmem/teams_mgmt.h @@ -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 +. */ + +#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 diff --git a/libgfortran/caf/shmem/thread_support.c b/libgfortran/caf/shmem/thread_support.c new file mode 100644 index 00000000000..572f39400b3 --- /dev/null +++ b/libgfortran/caf/shmem/thread_support.c @@ -0,0 +1,73 @@ +/* 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 +. */ + +#include "thread_support.h" + +#include +#include +#include + +#define ERRCHECK(a) \ + do \ + { \ + int rc = a; \ + if (rc) \ + { \ + errno = rc; \ + perror (#a " failed"); \ + exit (1); \ + } \ + } \ + while (0) + +void +initialize_shared_mutex (pthread_mutex_t *mutex) +{ + pthread_mutexattr_t mattr; + ERRCHECK (pthread_mutexattr_init (&mattr)); + ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED)); + ERRCHECK (pthread_mutex_init (mutex, &mattr)); + ERRCHECK (pthread_mutexattr_destroy (&mattr)); +} + +void +initialize_shared_errorcheck_mutex (pthread_mutex_t *mutex) +{ + pthread_mutexattr_t mattr; + ERRCHECK (pthread_mutexattr_init (&mattr)); + ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED)); + ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK)); + ERRCHECK (pthread_mutex_init (mutex, &mattr)); + ERRCHECK (pthread_mutexattr_destroy (&mattr)); +} + +void +initialize_shared_condition (pthread_cond_t *cond) +{ + pthread_condattr_t cattr; + ERRCHECK (pthread_condattr_init (&cattr)); + ERRCHECK (pthread_condattr_setpshared (&cattr, PTHREAD_PROCESS_SHARED)); + ERRCHECK (pthread_cond_init (cond, &cattr)); + ERRCHECK (pthread_condattr_destroy (&cattr)); +} diff --git a/libgfortran/caf/shmem/thread_support.h b/libgfortran/caf/shmem/thread_support.h new file mode 100644 index 00000000000..e70b4b83c7d --- /dev/null +++ b/libgfortran/caf/shmem/thread_support.h @@ -0,0 +1,38 @@ +/* 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 +. */ + +#ifndef THREAD_SUPPORT_H +#define THREAD_SUPPORT_H + +#include + +/* Support routines to setup pthread structs in shared memory. */ + +void initialize_shared_mutex (pthread_mutex_t *); + +void initialize_shared_errorcheck_mutex (pthread_mutex_t *); + +void initialize_shared_condition (pthread_cond_t *); + +#endif diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 97876fa9d8c..a6576f28260 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -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); }