From 6955bb63595259d94a8c8eaba56650fe7652c3cd Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Thu, 17 Jul 2025 20:50:42 -0700 Subject: [PATCH 1/7] fortran: Testing patches for coarray shared memory. pr88076_v2_1.patch pr88076_v2_2.patch pr88076_v2_3.patch pr88076_v2_4.patch pr88076_v2_5.patch pr88076_v2_6.patch coarray_fixes_2.patch PR fortran/88076 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. * caf/caf_error.h: New file. * caf/shmem.c: New file. * caf/shmem/alloc.c: New file. * caf/shmem/alloc.h: New file. * caf/shmem/allocator.c: New file. * caf/shmem/allocator.h: New file. * caf/shmem/collective_subroutine.c: New file. * caf/shmem/collective_subroutine.h: New file. * caf/shmem/counter_barrier.c: New file. * caf/shmem/counter_barrier.h: New file. * caf/shmem/hashmap.c: New file. * caf/shmem/hashmap.h: New file. * caf/shmem/shared_memory.c: New file. * caf/shmem/shared_memory.h: New file. * caf/shmem/supervisor.c: New file. * caf/shmem/supervisor.h: New file. * caf/shmem/sync.c: New file. * caf/shmem/sync.h: New file. * caf/shmem/teams_mgmt.c: New file. * caf/shmem/teams_mgmt.h: New file. * caf/shmem/thread_support.c: New file. * caf/shmem/thread_support.h: New file. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/alloc_comp_4.f90: 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. * gfortran.dg/coarray/sync_team.f90: New test. --- gcc/fortran/check.cc | 11 +- gcc/fortran/coarray.cc | 26 +- gcc/fortran/invoke.texi | 54 + gcc/fortran/trans-decl.cc | 7 +- gcc/fortran/trans-expr.cc | 68 +- gcc/fortran/trans-intrinsic.cc | 6 +- gcc/fortran/trans-stmt.cc | 7 +- .../gfortran.dg/coarray/alloc_comp_4.f90 | 16 +- .../gfortran.dg/coarray/atomic_2.f90 | 25 +- gcc/testsuite/gfortran.dg/coarray/caf.exp | 13 + .../gfortran.dg/coarray/co_reduce_string.f90 | 94 + .../gfortran.dg/coarray/coarray_allocated.f90 | 9 +- .../gfortran.dg/coarray/coindexed_1.f90 | 74 +- .../gfortran.dg/coarray/coindexed_3.f08 | 4 +- .../gfortran.dg/coarray/coindexed_5.f90 | 108 +- gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 1 + gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 75 +- gcc/testsuite/gfortran.dg/coarray/event_3.f08 | 4 +- gcc/testsuite/gfortran.dg/coarray/event_4.f08 | 3 +- .../gfortran.dg/coarray/failed_images_1.f08 | 2 +- .../gfortran.dg/coarray/failed_images_2.f08 | 39 +- .../gfortran.dg/coarray/image_status_1.f08 | 2 +- .../gfortran.dg/coarray/image_status_2.f08 | 32 +- gcc/testsuite/gfortran.dg/coarray/lock_2.f90 | 2 + .../gfortran.dg/coarray/poly_run_3.f90 | 8 +- .../gfortran.dg/coarray/scalar_alloc_1.f90 | 13 +- .../gfortran.dg/coarray/stopped_images_1.f08 | 2 +- .../gfortran.dg/coarray/stopped_images_2.f08 | 39 +- gcc/testsuite/gfortran.dg/coarray/sync_1.f90 | 8 +- gcc/testsuite/gfortran.dg/coarray/sync_3.f90 | 26 +- .../gfortran.dg/coarray/sync_team.f90 | 33 + .../gfortran.dg/coarray_sync_memory.f90 | 4 +- libgfortran/Makefile.am | 23 +- libgfortran/Makefile.in | 135 +- libgfortran/caf/caf_error.c | 71 + libgfortran/caf/caf_error.h | 44 + libgfortran/caf/libcaf.h | 12 +- libgfortran/caf/shmem.c | 1882 +++++++++++++++++ libgfortran/caf/shmem/alloc.c | 168 ++ libgfortran/caf/shmem/alloc.h | 80 + libgfortran/caf/shmem/allocator.c | 131 ++ libgfortran/caf/shmem/allocator.h | 88 + libgfortran/caf/shmem/collective_subroutine.c | 434 ++++ libgfortran/caf/shmem/collective_subroutine.h | 50 + libgfortran/caf/shmem/counter_barrier.c | 121 ++ libgfortran/caf/shmem/counter_barrier.h | 76 + libgfortran/caf/shmem/hashmap.c | 366 ++++ libgfortran/caf/shmem/hashmap.h | 98 + libgfortran/caf/shmem/shared_memory.c | 200 ++ libgfortran/caf/shmem/shared_memory.h | 93 + libgfortran/caf/shmem/supervisor.c | 311 +++ libgfortran/caf/shmem/supervisor.h | 112 + libgfortran/caf/shmem/sync.c | 182 ++ libgfortran/caf/shmem/sync.h | 79 + libgfortran/caf/shmem/teams_mgmt.c | 83 + libgfortran/caf/shmem/teams_mgmt.h | 93 + libgfortran/caf/shmem/thread_support.c | 73 + libgfortran/caf/shmem/thread_support.h | 38 + libgfortran/caf/single.c | 2 +- 59 files changed, 5633 insertions(+), 227 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90 create mode 100644 libgfortran/caf/caf_error.c create mode 100644 libgfortran/caf/caf_error.h create mode 100644 libgfortran/caf/shmem.c create mode 100644 libgfortran/caf/shmem/alloc.c create mode 100644 libgfortran/caf/shmem/alloc.h create mode 100644 libgfortran/caf/shmem/allocator.c create mode 100644 libgfortran/caf/shmem/allocator.h create mode 100644 libgfortran/caf/shmem/collective_subroutine.c create mode 100644 libgfortran/caf/shmem/collective_subroutine.h create mode 100644 libgfortran/caf/shmem/counter_barrier.c create mode 100644 libgfortran/caf/shmem/counter_barrier.h create mode 100644 libgfortran/caf/shmem/hashmap.c create mode 100644 libgfortran/caf/shmem/hashmap.h create mode 100644 libgfortran/caf/shmem/shared_memory.c create mode 100644 libgfortran/caf/shmem/shared_memory.h create mode 100644 libgfortran/caf/shmem/supervisor.c create mode 100644 libgfortran/caf/shmem/supervisor.h create mode 100644 libgfortran/caf/shmem/sync.c create mode 100644 libgfortran/caf/shmem/sync.h create mode 100644 libgfortran/caf/shmem/teams_mgmt.c create mode 100644 libgfortran/caf/shmem/teams_mgmt.h create mode 100644 libgfortran/caf/shmem/thread_support.c create mode 100644 libgfortran/caf/shmem/thread_support.h diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 838d523f7c40..3446c88b5019 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 ef8fd4e42d0a..c611b5399687 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 0b893e876a5d..77926fa02599 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 43bd7be54cb7..ba4a842a0257 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 082987f9cb84..d97d1356ab6a 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 @@ -760,11 +770,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)); @@ -775,15 +817,18 @@ gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, gfc_conv_descriptor_dtype (rhs_desc)); /* Assign the dimension as range-ref. */ - tmp = gfc_get_descriptor_dimension (lhs_desc); - tmp2 = gfc_get_descriptor_dimension (rhs_desc); + lhs_dim = gfc_get_descriptor_dimension (lhs_desc); + rhs_dim = gfc_get_descriptor_dimension (rhs_desc); - type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); - tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - gfc_add_modify (block, tmp, tmp2); + type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim); + lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, lhs_dim, rhs_dim); + + /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ + copy_coarray_desc_part (block, lhs_desc, rhs_desc); } /* Takes a derived type expression and returns the address of a temporary @@ -899,6 +944,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 be984271d6a8..7cd95da71169 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 f10540158627..eadd40cafd89 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 2ee8ff0253d6..50b4bab1603a 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 5e1c4967248c..7eccd7b578ca 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 c1e8e8ca2b0b..1f002e08fa3f 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 000000000000..9b4c44f1ada6 --- /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 27db0e8d8ce0..ce7c6288a611 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 f90b65cb3898..8f7a83a9c996 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 7fd20851e0a9..145835d461b3 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 c35ec1093c1f..8eb646696280 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 4b45daab6493..c569390e7c62 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 81dc90b7197b..a9fecf939843 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 +associate (me => this_image(), np => num_images()) + allocate(events(np)[*]) -stat = 99 -event post (var, stat=stat) -if (stat /= 0) STOP 2 -call event_query(var, count, stat=stat) -if (count /= 1 .or. stat /= 0) STOP 3 + associate(var => events(me)) + count = -42 + call event_query (var, count) + if (count /= 0) STOP 1 -stat = 99 -event post (var[this_image()]) -call event_query(var, count) -if (count /= 2) STOP 4 + stat = 99 + event post (var, stat=stat) + if (stat /= 0) STOP 2 + call event_query(var, count, stat=stat) + if (count /= 1 .or. stat /= 0) STOP 3 -stat = 99 -event wait (var) -call event_query(var, count) -if (count /= 1) STOP 5 + count = 99 + event post (var[this_image()]) + call event_query(var, count) + if (count /= 2) STOP 4 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 2) STOP 6 + count = 99 + event wait (var) + call event_query(var, count) + if (count /= 1) STOP 5 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 3) STOP 7 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 2) STOP 6 -stat = 99 -event wait (var, until_count=2) -call event_query(var, count) -if (count /= 1) STOP 8 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 3) STOP 7 -stat = 99 -event wait (var, stat=stat, until_count=1) -if (stat /= 0) STOP 9 -call event_query(event=var, stat=stat, count=count) -if (count /= 0 .or. stat /= 0) STOP 10 + count = 99 + event wait (var, until_count=2) + call event_query(var, count) + if (count /= 1) STOP 8 + + stat = 99 + event wait (var, stat=stat, until_count=1) + if (stat /= 0) STOP 9 + count = 99 + call event_query(event=var, stat=stat, count=count) + if (count /= 0 .or. stat /= 0) STOP 10 + end associate +end associate end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index 60d3193f776d..cedf636b79b3 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 de901c01aa43..26a1f59df030 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 4898dd8a7a2f..34ae131d15f1 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 ca5fe4020d5e..78d92daf0715 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 b7ec5a6a9c97..f725f81d4aad 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 fb49289cb782..8866f2374819 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 8e96154996d4..3d445b9b5e82 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 c284a5667607..4da1b9569fe6 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 b0d27bdfb8fa..8dd7df5d4362 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 403de585b9af..7658e6bb6bbb 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 0bf4a81a7e20..dadd00ecda7a 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 8633c4aa527d..4abe5a3b5487 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 fe1e4c548c85..ceb4b19d5171 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 000000000000..a96884549a3d --- /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 c4e660b8cf72..0030d91257d5 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 4f3b30332245..f912824d208b 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 dd88f8893b7f..003c2f13362a 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 000000000000..a8f3bf7f189b --- /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 000000000000..15455377eb03 --- /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 7267bc76905e..80ea72ff7426 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 000000000000..b8d92d657f5f --- /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 000000000000..fecf97c03ffa --- /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 000000000000..d85b1a30236c --- /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 000000000000..d900167cfc24 --- /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 000000000000..53b6abeeba11 --- /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 000000000000..257a048d63d5 --- /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 000000000000..8c37186c867b --- /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 000000000000..f78ba7fe852d --- /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 000000000000..a28c58812a54 --- /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 000000000000..e17d6dd2dcab --- /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 000000000000..bc263d32dcd4 --- /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 000000000000..2b3666ddd3b9 --- /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 000000000000..01ac2811e5d6 --- /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 000000000000..9e5b794a23f0 --- /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 000000000000..7afb82696749 --- /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 000000000000..a456244629ca --- /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 000000000000..a3e586bca244 --- /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 000000000000..44a34d727c36 --- /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 000000000000..f96f4aea33e6 --- /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 000000000000..572f39400b38 --- /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 000000000000..e70b4b83c7d6 --- /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 97876fa9d8c2..a6576f28260c 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); } From 75164bb769816261706d317e08a5fee6d8ba49b6 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 29 Jul 2025 10:54:39 -0700 Subject: [PATCH 2/7] Revert "fortran: Testing patches for coarray shared memory." This reverts commit 6955bb63595259d94a8c8eaba56650fe7652c3cd. --- gcc/fortran/check.cc | 11 +- gcc/fortran/coarray.cc | 26 +- gcc/fortran/invoke.texi | 54 - gcc/fortran/trans-decl.cc | 7 +- gcc/fortran/trans-expr.cc | 68 +- gcc/fortran/trans-intrinsic.cc | 6 +- gcc/fortran/trans-stmt.cc | 7 +- .../gfortran.dg/coarray/alloc_comp_4.f90 | 16 +- .../gfortran.dg/coarray/atomic_2.f90 | 25 +- gcc/testsuite/gfortran.dg/coarray/caf.exp | 13 - .../gfortran.dg/coarray/co_reduce_string.f90 | 94 - .../gfortran.dg/coarray/coarray_allocated.f90 | 9 +- .../gfortran.dg/coarray/coindexed_1.f90 | 74 +- .../gfortran.dg/coarray/coindexed_3.f08 | 4 +- .../gfortran.dg/coarray/coindexed_5.f90 | 108 +- gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 1 - gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 75 +- gcc/testsuite/gfortran.dg/coarray/event_3.f08 | 4 +- gcc/testsuite/gfortran.dg/coarray/event_4.f08 | 3 +- .../gfortran.dg/coarray/failed_images_1.f08 | 2 +- .../gfortran.dg/coarray/failed_images_2.f08 | 39 +- .../gfortran.dg/coarray/image_status_1.f08 | 2 +- .../gfortran.dg/coarray/image_status_2.f08 | 32 +- gcc/testsuite/gfortran.dg/coarray/lock_2.f90 | 2 - .../gfortran.dg/coarray/poly_run_3.f90 | 8 +- .../gfortran.dg/coarray/scalar_alloc_1.f90 | 13 +- .../gfortran.dg/coarray/stopped_images_1.f08 | 2 +- .../gfortran.dg/coarray/stopped_images_2.f08 | 39 +- gcc/testsuite/gfortran.dg/coarray/sync_1.f90 | 8 +- gcc/testsuite/gfortran.dg/coarray/sync_3.f90 | 26 +- .../gfortran.dg/coarray/sync_team.f90 | 33 - .../gfortran.dg/coarray_sync_memory.f90 | 4 +- libgfortran/Makefile.am | 23 +- libgfortran/Makefile.in | 135 +- libgfortran/caf/caf_error.c | 71 - libgfortran/caf/caf_error.h | 44 - libgfortran/caf/libcaf.h | 12 +- libgfortran/caf/shmem.c | 1882 ----------------- libgfortran/caf/shmem/alloc.c | 168 -- libgfortran/caf/shmem/alloc.h | 80 - libgfortran/caf/shmem/allocator.c | 131 -- libgfortran/caf/shmem/allocator.h | 88 - libgfortran/caf/shmem/collective_subroutine.c | 434 ---- libgfortran/caf/shmem/collective_subroutine.h | 50 - libgfortran/caf/shmem/counter_barrier.c | 121 -- libgfortran/caf/shmem/counter_barrier.h | 76 - libgfortran/caf/shmem/hashmap.c | 366 ---- libgfortran/caf/shmem/hashmap.h | 98 - libgfortran/caf/shmem/shared_memory.c | 200 -- libgfortran/caf/shmem/shared_memory.h | 93 - libgfortran/caf/shmem/supervisor.c | 311 --- libgfortran/caf/shmem/supervisor.h | 112 - libgfortran/caf/shmem/sync.c | 182 -- libgfortran/caf/shmem/sync.h | 79 - libgfortran/caf/shmem/teams_mgmt.c | 83 - libgfortran/caf/shmem/teams_mgmt.h | 93 - libgfortran/caf/shmem/thread_support.c | 73 - libgfortran/caf/shmem/thread_support.h | 38 - libgfortran/caf/single.c | 2 +- 59 files changed, 227 insertions(+), 5633 deletions(-) delete mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 delete mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90 delete mode 100644 libgfortran/caf/caf_error.c delete mode 100644 libgfortran/caf/caf_error.h delete mode 100644 libgfortran/caf/shmem.c delete mode 100644 libgfortran/caf/shmem/alloc.c delete mode 100644 libgfortran/caf/shmem/alloc.h delete mode 100644 libgfortran/caf/shmem/allocator.c delete mode 100644 libgfortran/caf/shmem/allocator.h delete mode 100644 libgfortran/caf/shmem/collective_subroutine.c delete mode 100644 libgfortran/caf/shmem/collective_subroutine.h delete mode 100644 libgfortran/caf/shmem/counter_barrier.c delete mode 100644 libgfortran/caf/shmem/counter_barrier.h delete mode 100644 libgfortran/caf/shmem/hashmap.c delete mode 100644 libgfortran/caf/shmem/hashmap.h delete mode 100644 libgfortran/caf/shmem/shared_memory.c delete mode 100644 libgfortran/caf/shmem/shared_memory.h delete mode 100644 libgfortran/caf/shmem/supervisor.c delete mode 100644 libgfortran/caf/shmem/supervisor.h delete mode 100644 libgfortran/caf/shmem/sync.c delete mode 100644 libgfortran/caf/shmem/sync.h delete mode 100644 libgfortran/caf/shmem/teams_mgmt.c delete mode 100644 libgfortran/caf/shmem/teams_mgmt.h delete mode 100644 libgfortran/caf/shmem/thread_support.c delete mode 100644 libgfortran/caf/shmem/thread_support.h diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 3446c88b5019..838d523f7c40 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, 1) && team_type_check (team, 1)); + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } @@ -1878,8 +1878,13 @@ 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 && (!scalar_check (team, 0) || !team_type_check (team, 0))) - return false; + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &team->where); + return false; + } if (kind) { diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index c611b5399687..ef8fd4e42d0a 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -696,23 +696,17 @@ 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)) - { - /* Only allow pure and elemental function calls in a coarray - accessor, because all other may have side effects or access - pointers, which may not be possible in the accessor running on - another host. */ - for (gfc_actual_arglist *actual = e->value.function.actual; - actual; actual = actual->next) - check_add_new_component (type, actual->expr, add_data); - } - else - /* Extract the expression, evaluate it and add a temporary with its - value to the helper structure. */ + if (!e->symtree->n.sym->attr.pure + && !e->symtree->n.sym->attr.elemental + && !(e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental))) + /* Treat non-pure/non-elemental functions. */ check_add_new_comp_handle_array (e, type, add_data); + else + for (gfc_actual_arglist *actual = e->value.function.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, add_data); break; case EXPR_VARIABLE: check_add_new_comp_handle_array (e, type, add_data); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 77926fa02599..0b893e876a5d 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -104,7 +104,6 @@ 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 @@ -2281,56 +2280,3 @@ 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 ba4a842a0257..43bd7be54cb7 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4223,9 +4223,10 @@ 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, pvoid_type_node); + gfor_fndecl_caf_team_number + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_team_number")), ". r ", + integer_type_node, 1, integer_type_node); gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX ("caf_image_status")), ". r r ", diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index d97d1356ab6a..082987f9cb84 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -90,8 +90,6 @@ 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; @@ -102,16 +100,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) if (POINTER_TYPE_P (TREE_TYPE (scalar))) scalar = TREE_TYPE (scalar); - if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar))) - { - struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)); - codim = lang_specific->corank; - lbound = lang_specific->lbound; - ubound = lang_specific->ubound; - } - return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound, - ubound, 1, akind, - !(attr.pointer || attr.target)); + return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1, + akind, !(attr.pointer || attr.target)); } tree @@ -770,43 +760,11 @@ 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 lhs_dim, rhs_dim, type; + tree tmp, tmp2, type; gfc_conv_descriptor_data_set (block, lhs_desc, gfc_conv_descriptor_data_get (rhs_desc)); @@ -817,18 +775,15 @@ 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. */ - lhs_dim = gfc_get_descriptor_dimension (lhs_desc); - rhs_dim = gfc_get_descriptor_dimension (rhs_desc); + tmp = gfc_get_descriptor_dimension (lhs_desc); + tmp2 = 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); - - /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ - copy_coarray_desc_part (block, lhs_desc, rhs_desc); + type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, tmp, tmp2); } /* Takes a derived type expression and returns the address of a temporary @@ -944,7 +899,6 @@ 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 7cd95da71169..be984271d6a8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2073,13 +2073,9 @@ 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 - : gfc_build_addr_expr (NULL_TREE, args[1])); + num_args < 2 ? null_pointer_node : args[1]); else gcc_unreachable (); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index eadd40cafd89..f10540158627 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1362,8 +1362,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, code->expr1); - images = gfc_trans_force_lval (&argse.pre, argse.expr); - gfc_add_block_to_block (&se.pre, &argse.pre); + images = argse.expr; } if (code->expr2) @@ -1373,7 +1372,6 @@ 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; @@ -1386,9 +1384,8 @@ 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 = argse.expr; + errmsg = gfc_build_addr_expr (NULL, argse.expr); errmsglen = fold_convert (size_type_node, argse.string_length); - gfc_add_block_to_block (&se.pre, &argse.pre); } else if (flag_coarray == GFC_FCOARRAY_LIB) { diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 index 50b4bab1603a..2ee8ff0253d6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 @@ -11,19 +11,11 @@ program main end type type(mytype), save :: object[*] - integer :: me, other + integer :: me me=this_image() - other = me + 1 - if (other .GT. num_images()) other = 1 - if (me == num_images()) then - allocate(object%indices(me/2)) - else - allocate(object%indices(me)) - end if - object%indices = 42 * me + allocate(object%indices(me)) + object%indices = 42 - sync all - if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1 - sync all + if ( any( object[me]%indices(:) /= 42 ) ) STOP 1 end program diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 index 7eccd7b578ca..5e1c4967248c 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() * 2) STOP 12 +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12 do i = 1, num_images() call atomic_ref(var, caf[i], stat=stat) if (stat /= 0 .or. var /= num_images() + i) STOP 13 @@ -328,7 +328,7 @@ end do sync all call atomic_ref(var, caf[num_images()], stat=stat) -if (stat /= 0 .or. var /= num_images() * 2) STOP 45 +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45 do i = 1, num_images() call atomic_ref(var, caf[i], stat=stat) if (stat /= 0 .or. var /= num_images() + i) STOP 46 @@ -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) STOP 53 + if (stat /= 0 .or. var <= 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) STOP 68 + if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68 end do end if sync all @@ -628,27 +628,26 @@ sync all if (this_image() == 1) then call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 82 call atomic_ref(var2, caf_log[num_images()], stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 83 end if sync all -if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84 +if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84 call atomic_ref(var2, caf_log[num_images()], stat=stat) -if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85 +if (stat /= 0 .or. var2 .neqv. .true.) STOP 85 sync all if (this_image() == 1) then call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 86 call atomic_ref(var2, caf_log[num_images()], stat=stat) - if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87 + if (stat /= 0 .or. var2 .neqv. .false.) STOP 87 end if sync all -if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88 +if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88 call atomic_ref(var2, caf_log[num_images()], stat=stat) -if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89 -sync all +if (stat /= 0 .or. var2 .neqv. .false.) STOP 89 end diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp index 1f002e08fa3f..c1e8e8ca2b0b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/caf.exp +++ b/gcc/testsuite/gfortran.dg/coarray/caf.exp @@ -70,12 +70,6 @@ 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. @@ -109,13 +103,6 @@ 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 deleted file mode 100644 index 9b4c44f1ada6..000000000000 --- a/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 +++ /dev/null @@ -1,94 +0,0 @@ -!{ 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 ce7c6288a611..27db0e8d8ce0 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,1,1])) stop 4 + if (allocated (c%x[1,2,3])) stop 4 ! Allocate collectively allocate(a[*]) @@ -28,17 +28,16 @@ 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,1,1])) stop 8 + if (.not. allocated (c%x[1,2,3])) stop 8 - sync all - ! Dellocate collectively + ! Deallocate collectively deallocate(a) deallocate(c%x) if (allocated (a)) stop 9 if (allocated (c%x)) stop 10 if (allocated (a[1])) stop 11 - if (allocated (c%x[1,1,1])) stop 12 + if (allocated (c%x[1,2,3])) stop 12 end ! Expected: always local access and never a call to _gfortran_caf_get diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 index 8f7a83a9c996..f90b65cb3898 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 @@ -21,7 +21,6 @@ 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 @@ -38,7 +37,6 @@ 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 @@ -55,7 +53,6 @@ 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 @@ -72,7 +69,6 @@ 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 @@ -95,7 +91,6 @@ 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 @@ -118,7 +113,6 @@ 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 @@ -141,7 +135,6 @@ 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 @@ -164,7 +157,6 @@ 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 @@ -187,7 +179,6 @@ 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 @@ -208,7 +199,6 @@ 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 @@ -229,7 +219,6 @@ 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 @@ -250,7 +239,6 @@ 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 @@ -273,7 +261,6 @@ 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 @@ -290,7 +277,6 @@ 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 @@ -307,7 +293,6 @@ 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 @@ -324,7 +309,6 @@ 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 @@ -347,7 +331,6 @@ 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 @@ -370,7 +353,6 @@ 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 @@ -393,7 +375,6 @@ 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 @@ -416,7 +397,6 @@ 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 @@ -439,7 +419,6 @@ 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 @@ -460,7 +439,6 @@ 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 @@ -481,7 +459,6 @@ 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 @@ -502,7 +479,6 @@ 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 @@ -526,7 +502,6 @@ 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 @@ -543,7 +518,6 @@ 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 @@ -560,7 +534,6 @@ 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 @@ -577,7 +550,6 @@ 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 @@ -600,7 +572,6 @@ 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 @@ -623,7 +594,6 @@ 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 @@ -646,7 +616,6 @@ 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 @@ -669,7 +638,6 @@ 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 @@ -692,7 +660,6 @@ 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 @@ -713,7 +680,6 @@ 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 @@ -734,7 +700,6 @@ 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 @@ -755,7 +720,6 @@ 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 @@ -779,8 +743,7 @@ subroutine char_test() str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" ustr1a = 4_"abc" - str2a = 1_"XXXXXXX" - sync all + str1a = 1_"XXXXXXX" if (this_image() == num_images()) then str2a[1] = ustr1a end if @@ -797,7 +760,6 @@ 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 @@ -814,7 +776,6 @@ 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 @@ -831,7 +792,6 @@ 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 @@ -854,7 +814,6 @@ 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 @@ -877,7 +836,6 @@ 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 @@ -900,7 +858,6 @@ 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 @@ -923,7 +880,6 @@ 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 @@ -946,7 +902,6 @@ 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 @@ -967,7 +922,6 @@ 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 @@ -988,7 +942,6 @@ 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 @@ -1009,7 +962,6 @@ 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 @@ -1032,7 +984,6 @@ 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 @@ -1049,7 +1000,6 @@ 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 @@ -1066,7 +1016,6 @@ 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 @@ -1083,7 +1032,6 @@ 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 @@ -1106,7 +1054,6 @@ 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 @@ -1129,7 +1076,6 @@ 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 @@ -1152,7 +1098,6 @@ 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 @@ -1175,7 +1120,6 @@ 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 @@ -1198,7 +1142,6 @@ 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 @@ -1219,7 +1162,6 @@ 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 @@ -1240,7 +1182,6 @@ 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 @@ -1261,7 +1202,6 @@ 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 @@ -1285,7 +1225,6 @@ 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 @@ -1302,7 +1241,6 @@ 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 @@ -1319,7 +1257,6 @@ 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 @@ -1336,7 +1273,6 @@ 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 @@ -1359,7 +1295,6 @@ 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 @@ -1382,7 +1317,6 @@ 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 @@ -1405,7 +1339,6 @@ 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 @@ -1428,7 +1361,6 @@ 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 @@ -1451,7 +1383,6 @@ 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 @@ -1472,7 +1403,6 @@ 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 @@ -1493,7 +1423,6 @@ 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 @@ -1514,7 +1443,6 @@ 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 145835d461b3..7fd20851e0a9 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 - sync all - + ! Checking against single image only. Therefore team statements are + ! not viable nor are they (yet) supported by GFortran. if (a[1, team_number=-1, stat=s] /= 42) stop 1 if (s /= 0) stop 2 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 index 8eb646696280..c35ec1093c1f 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -13,72 +13,68 @@ program coindexed_5 parentteam = get_team() caf = [23, 32] - form team(t_num, team) !, new_index=num_images() - this_image() + 1) + form team(t_num, team, new_index=1) form team(t_num, formed_team) change team(team, cell[*] => caf(2)) - associate(me => this_image()) - ! for get_from_remote - ! Checking against caf_single is very limitted. - if (cell[me, team_number=t_num] /= 32) stop 1 - if (cell[me, team_number=st_num] /= 32) stop 2 - if (cell[me, team=parentteam] /= 32) stop 3 + ! for get_from_remote + ! Checking against caf_single is very limitted. + if (cell[1, team_number=t_num] /= 32) stop 1 + if (cell[1, team_number=st_num] /= 32) stop 2 + if (cell[1, team=parentteam] /= 32) stop 3 - ! Check that team_number is validated - lhs = cell[me, team_number=5, stat=stat] - if (stat /= 1) stop 4 + ! Check that team_number is validated + lhs = cell[1, team_number=5, stat=stat] + if (stat /= 1) stop 4 - ! Check that only access to active teams is valid - stat = 42 - lhs = cell[me, team=formed_team, stat=stat] - if (stat /= 1) stop 5 + ! Check that only access to active teams is valid + stat = 42 + lhs = cell[1, team=formed_team, stat=stat] + if (stat /= 1) stop 5 - ! for send_to_remote - ! Checking against caf_single is very limitted. - cell[me, team_number=t_num] = 45 - if (cell /= 45) stop 11 - cell[me, team_number=st_num] = 46 - if (cell /= 46) stop 12 - cell[me, team=parentteam] = 47 - if (cell /= 47) stop 13 + ! for send_to_remote + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = 45 + if (cell /= 45) stop 11 + cell[1, team_number=st_num] = 46 + if (cell /= 46) stop 12 + cell[1, team=parentteam] = 47 + if (cell /= 47) stop 13 - ! Check that team_number is validated - stat = -1 - cell[me, team_number=5, stat=stat] = 0 - if (stat /= 1) stop 14 + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = 0 + if (stat /= 1) stop 14 - ! Check that only access to active teams is valid - stat = 42 - cell[me, team=formed_team, stat=stat] = -1 - if (stat /= 1) stop 15 + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = -1 + if (stat /= 1) stop 15 - ! for transfer_between_remotes - ! Checking against caf_single is very limitted. - cell[me, team_number=t_num] = caf(1)[me, team_number=-1] - if (cell /= 23) stop 21 - cell[me, team_number=st_num] = caf(2)[me, team_number=-1] - ! cell is an alias for caf(2) and has been overwritten by caf(1)! - if (cell /= 23) stop 22 - cell[me, team=parentteam] = caf(1)[me, team= team] - if (cell /= 23) stop 23 + ! for transfer_between_remotes + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = caf(1)[1, team_number=-1] + if (cell /= 23) stop 21 + cell[1, team_number=st_num] = caf(2)[1, team_number=-1] + ! cell is an alias for caf(2) and has been overwritten by caf(1)! + if (cell /= 23) stop 22 + cell[1, team=parentteam] = caf(1)[1, team= team] + if (cell /= 23) stop 23 - ! Check that team_number is validated - stat = -1 - cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1] - if (stat /= 1) stop 24 - stat = -1 - cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat] - if (stat /= 1) stop 25 + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1] + if (stat /= 1) stop 24 + stat = -1 + cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat] + if (stat /= 1) stop 25 - ! Check that only access to active teams is valid - stat = 42 - cell[me, team=formed_team, stat=stat] = caf(1)[me] - if (stat /= 1) stop 26 - stat = 42 - cell[me] = caf(1)[me, team=formed_team, stat=stat] - if (stat /= 1) stop 27 - - sync all - end associate + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = caf(1)[1] + if (stat /= 1) stop 26 + stat = 42 + cell[1] = caf(1)[1, team=formed_team, stat=stat] + if (stat /= 1) stop 27 end team end program coindexed_5 diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 index c569390e7c62..4b45daab6493 100644 --- a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 @@ -15,7 +15,6 @@ 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 a9fecf939843..81dc90b7197b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 @@ -5,54 +5,47 @@ use iso_fortran_env, only: event_type implicit none -type(event_type), save, allocatable, dimension(:) :: events[:] +type(event_type), save :: var[*] integer :: count, stat -associate (me => this_image(), np => num_images()) - allocate(events(np)[*]) +count = -42 +call event_query (var, count) +if (count /= 0) STOP 1 - 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 - 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 - count = 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 - count = 99 - event wait (var) - call event_query(var, count) - if (count /= 1) STOP 5 +stat = 99 +event post (var) +call event_query(var, count) +if (count /= 2) STOP 6 - count = 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 - count = 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 - 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 +stat = 99 +event wait (var, stat=stat, until_count=1) +if (stat /= 0) STOP 9 +call event_query(event=var, stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 10 end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index cedf636b79b3..60d3193f776d 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[this_image()]) - event post(x[this_image()]) + event post(x[1]) + event post(x[1]) call event_query(x, cnt) if (cnt /= 2) error stop 1 event wait(x, until_count=2) diff --git a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 index 26a1f59df030..de901c01aa43 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 @@ -8,6 +8,5 @@ program event_4 type(event_type) done[*] nc(1) = 1 event post(done[1]) - if (this_image() == 1) event wait(done,until_count=nc(1)) - sync all + event wait(done,until_count=nc(1)) end diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 index 34ae131d15f1..4898dd8a7a2f 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\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" } + fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" } fi = failed_images(KIND=1) ! OK fi = failed_images(KIND=4) ! OK fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" } diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 index 78d92daf0715..ca5fe4020d5e 100644 --- a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 @@ -1,44 +1,17 @@ ! { dg-do run } program test_failed_images_2 - use iso_fortran_env implicit none - type(team_type) :: t integer, allocatable :: fi(:) integer(kind=1), allocatable :: sfi(:) - integer, allocatable :: rem_images(:) - integer :: i, st - associate(np => num_images()) - form team (1, t) - fi = failed_images() - if (size(fi) > 0) stop 1 - sfi = failed_images(KIND=1) - if (size(sfi) > 0) stop 2 - sfi = failed_images(KIND=8) - if (size(sfi) > 0) stop 3 - - fi = failed_images(t) - if (size(fi) > 0) stop 4 + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" - if (num_images() > 1) then - sync all - if (this_image() == 2) fail image - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on a failed image. Try with a sleep. - do i = 0, 10 - if (size(failed_images()) == 0) then - call sleep(1) - else - exit - end if - end do - if (i == 10 .AND. size(failed_images()) == 0) stop 5 - sync images (rem_images, stat=st) - if (any(failed_images() /= [2])) stop 6 - if (any(failed_images(t, 8) /= [2])) stop 7 - end if - end associate end program test_failed_images_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index f725f81d4aad..b7ec5a6a9c97 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 "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" } + isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" } isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 index 8866f2374819..fb49289cb782 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 @@ -1,38 +1,12 @@ ! { dg-do run } program test_image_status_2 - use iso_fortran_env + use iso_fortran_env , only : STAT_STOPPED_IMAGE implicit none - type(team_type) :: t - integer :: i, st - integer, allocatable :: rem_images(:) - - form team (1, t) - if (image_status(1) /= 0) error stop "Image 1 should report OK." - if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped." - - if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK." - - if (num_images() > 1) then - associate (np => num_images()) - sync all - if (this_image() == 2) fail image - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on failed image. Try with a sleep. - do i = 0, 10 - if (image_status(2) /= STAT_FAILED_IMAGE) then - call sleep(1) - else - exit - end if - end do - sync images (rem_images, stat=st) - if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed." - if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed." - end associate - end if + if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped." + if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped." end program test_image_status_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 index 3d445b9b5e82..8e96154996d4 100644 --- a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 @@ -58,8 +58,6 @@ 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 4da1b9569fe6..c284a5667607 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) /= num_images())) STOP 3 +if (any (ucobound(a) /= this_image())) STOP 3 deallocate(a) allocate(b[*]) if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) & STOP 4 if (any (lcobound(b) /= 1)) STOP 5 -if (any (ucobound(b) /= num_images())) STOP 6 +if (any (ucobound(b) /= this_image())) STOP 6 deallocate(b) allocate(a(1)[-10:*]) if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & STOP 7 if (any (lcobound(a) /= -10)) STOP 8 -if (any (ucobound(a) /= -11 + num_images())) STOP 9 +if (any (ucobound(a) /= -11+this_image())) STOP 9 deallocate(a) allocate(d[23:*]) if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) & STOP 10 if (any (lcobound(d) /= 23)) STOP 11 -if (any (ucobound(d) /= 22 + num_images())) STOP 12 +if (any (ucobound(d) /= 22+this_image())) STOP 12 deallocate(d) end diff --git a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 index 8dd7df5d4362..b0d27bdfb8fa 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 () + 3] = 8 - 2*this_image () +a[this_image ()] = 8 - 2*this_image () if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) & STOP 4 @@ -30,7 +30,6 @@ 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 @@ -48,8 +47,7 @@ contains STOP 8 if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) & STOP 9 - if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10 - sync all + if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3 deallocate(x) end subroutine sub @@ -58,13 +56,12 @@ contains integer, allocatable, SAVE :: a[:] if (init) then - if (allocated(a)) STOP 11 + if (allocated(a)) STOP 10 allocate(a[*]) a = 45 else - if (.not. allocated(a)) STOP 12 - if (a /= 45) STOP 13 - sync all + if (.not. allocated(a)) STOP 11 + if (a /= 45) STOP 12 deallocate(a) end if end subroutine two diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 index 7658e6bb6bbb..403de585b9af 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\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" } + gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" } gi = stopped_images(KIND=1) ! OK gi = stopped_images(KIND=4) ! OK gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" } diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 index dadd00ecda7a..0bf4a81a7e20 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 @@ -1,44 +1,17 @@ ! { dg-do run } program test_stopped_images_2 - use iso_fortran_env implicit none - type(team_type) :: t integer, allocatable :: si(:) integer(kind=1), allocatable :: ssi(:) - integer, allocatable :: rem_images(:) - integer :: i, st - associate(np => num_images()) - form team (1, t) - si = stopped_images() - if (size(si) > 0) stop 1 - ssi = stopped_images(KIND=1) - if (size(ssi) > 0) stop 2 - ssi = stopped_images(KIND=8) - if (size(ssi) > 0) stop 3 - - si = stopped_images(t) - if (size(si) > 0) stop 4 + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" - if (num_images() > 1) then - sync all - if (this_image() == 2) stop - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on a stopped image. Try with a sleep. - do i = 0, 10 - if (size(stopped_images()) == 0) then - call sleep(1) - else - exit - end if - end do - if (i == 10 .AND. size(stopped_images()) == 0) stop 5 - sync images (rem_images, stat=st) - if (any(stopped_images() /= [2])) stop 6 - if (any(stopped_images(t, 8) /= [2])) stop 7 - end if - end associate end program test_stopped_images_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 index 4abe5a3b5487..8633c4aa527d 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 @@ -26,6 +26,7 @@ n = 5 sync all (stat=n,errmsg=str) if (n /= 0) STOP 2 + ! ! Test SYNC MEMORY ! @@ -41,21 +42,17 @@ 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 @@ -64,5 +61,4 @@ 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 ceb4b19d5171..fe1e4c548c85 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 @@ -9,9 +9,8 @@ ! PR fortran/18918 implicit none -integer :: n, st -integer,allocatable :: others(:) -character(len=40) :: str +integer :: n +character(len=30) :: str critical end critical myCr: critical @@ -59,32 +58,17 @@ 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 -st = 0 -sync images (n, errmsg=str, stat=st) -if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7 - -! Do this only on image 1, or output of error messages will clutter -if (this_image() == 1) sync images (n) ! Invalid: "-1" +sync images ( num_images() ) +sync images (n) ! Invalid: "-1" end diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 deleted file mode 100644 index a96884549a3d..000000000000 --- a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!{ 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 0030d91257d5..c4e660b8cf72 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 f912824d208b..4f3b30332245 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -58,30 +58,13 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(version_arg) -Wc,-shared-libgcc libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP) -libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h -libcaf_shared_SRCS = caf/caf_error.c - -cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la +cafexeclib_LTLIBRARIES = libcaf_single.la cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) -libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS) +libcaf_single_la_SOURCES = caf/single.c libcaf_single_la_LDFLAGS = -static -libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS) +libcaf_single_la_DEPENDENCIES = caf/libcaf.h libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS) -libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \ - caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \ - caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \ - caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \ - caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c - -libcaf_shmem_la_LDFLAGS = -static -libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \ - caf/shmem/allocator.h caf/shmem/collective_subroutine.h \ - caf/shmem/counter_barrier.h caf/shmem/hashmap.h \ - caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \ - caf/shmem/teams_mgmt.h caf/shmem/thread_support.h -libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS) - if IEEE_SUPPORT fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 003c2f13362a..dd88f8893b7f 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -217,31 +217,21 @@ am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \ "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \ "$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)" LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES) -libcaf_shmem_la_LIBADD = -am__dirstamp = $(am__leading_dot)dirstamp -am__objects_1 = caf/caf_error.lo -am_libcaf_shmem_la_OBJECTS = $(am__objects_1) caf/shmem.lo \ - caf/shmem/alloc.lo caf/shmem/allocator.lo \ - caf/shmem/collective_subroutine.lo \ - caf/shmem/counter_barrier.lo caf/shmem/hashmap.lo \ - caf/shmem/shared_memory.lo caf/shmem/supervisor.lo \ - caf/shmem/sync.lo caf/shmem/teams_mgmt.lo \ - caf/shmem/thread_support.lo -libcaf_shmem_la_OBJECTS = $(am_libcaf_shmem_la_OBJECTS) libcaf_single_la_LIBADD = -am_libcaf_single_la_OBJECTS = caf/single.lo $(am__objects_1) +am__dirstamp = $(am__leading_dot)dirstamp +am_libcaf_single_la_OBJECTS = caf/single.lo libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS) libgfortran_la_LIBADD = -@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo -@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \ +@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo +@LIBGFOR_MINIMAL_FALSE@am__objects_2 = runtime/backtrace.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/convert_char.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/environ.lo runtime/error.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/fpu.lo runtime/main.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/pause.lo runtime/stop.lo -am__objects_4 = runtime/bounds.lo runtime/compile_options.lo \ +am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \ runtime/memory.lo runtime/string.lo runtime/select.lo \ - $(am__objects_2) $(am__objects_3) -am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \ + $(am__objects_1) $(am__objects_2) +am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \ generated/matmul_i4.lo generated/matmul_i8.lo \ generated/matmul_i16.lo generated/matmul_r4.lo \ generated/matmul_r8.lo generated/matmul_r10.lo \ @@ -249,9 +239,9 @@ am__objects_5 = 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_6 = generated/matmul_l4.lo generated/matmul_l8.lo \ +am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \ generated/matmul_l16.lo -am__objects_7 = generated/matmulavx128_i1.lo \ +am__objects_6 = generated/matmulavx128_i1.lo \ generated/matmulavx128_i2.lo generated/matmulavx128_i4.lo \ generated/matmulavx128_i8.lo generated/matmulavx128_i16.lo \ generated/matmulavx128_r4.lo generated/matmulavx128_r8.lo \ @@ -259,7 +249,7 @@ am__objects_7 = 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_8 = generated/all_l1.lo generated/all_l2.lo \ +am__objects_7 = generated/all_l1.lo generated/all_l2.lo \ generated/all_l4.lo generated/all_l8.lo generated/all_l16.lo \ generated/any_l1.lo generated/any_l2.lo generated/any_l4.lo \ generated/any_l8.lo generated/any_l16.lo \ @@ -548,17 +538,17 @@ am__objects_8 = 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_5) $(am__objects_6) $(am__objects_7) \ + $(am__objects_4) $(am__objects_5) $(am__objects_6) \ runtime/ISO_Fortran_binding.lo -@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \ +@LIBGFOR_MINIMAL_FALSE@am__objects_8 = io/close.lo io/file_pos.lo \ @LIBGFOR_MINIMAL_FALSE@ io/format.lo io/inquire.lo \ @LIBGFOR_MINIMAL_FALSE@ io/intrinsics.lo io/list_read.lo \ @LIBGFOR_MINIMAL_FALSE@ io/lock.lo io/open.lo io/read.lo \ @LIBGFOR_MINIMAL_FALSE@ io/transfer.lo io/transfer128.lo \ @LIBGFOR_MINIMAL_FALSE@ io/unit.lo io/unix.lo io/write.lo \ @LIBGFOR_MINIMAL_FALSE@ io/fbuf.lo io/async.lo -am__objects_10 = io/size_from_kind.lo $(am__objects_9) -@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \ +am__objects_9 = io/size_from_kind.lo $(am__objects_8) +@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/c99_functions.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/chdir.lo intrinsics/chmod.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/clock.lo \ @@ -582,8 +572,8 @@ am__objects_10 = io/size_from_kind.lo $(am__objects_9) @LIBGFOR_MINIMAL_FALSE@ intrinsics/system_clock.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/time.lo intrinsics/umask.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/unlink.lo -@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.lo -am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \ +@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo +am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \ intrinsics/args.lo intrinsics/cshift0.lo \ intrinsics/eoshift0.lo intrinsics/eoshift2.lo \ intrinsics/erfc_scaled.lo intrinsics/extends_type_of.lo \ @@ -598,12 +588,12 @@ am__objects_13 = 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_11) $(am__objects_12) -@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \ + runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11) +@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \ @IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \ @IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo -am__objects_15 = -am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \ +am__objects_14 = +am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \ generated/_abs_c10.lo generated/_abs_c16.lo \ generated/_abs_c17.lo generated/_abs_i4.lo \ generated/_abs_i8.lo generated/_abs_i16.lo \ @@ -689,9 +679,9 @@ am__objects_16 = 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_4) $(am__objects_8) \ - $(am__objects_10) $(am__objects_13) $(am__objects_14) \ - $(am__objects_15) $(am__objects_16) +am_libgfortran_la_OBJECTS = $(am__objects_3) $(am__objects_7) \ + $(am__objects_9) $(am__objects_12) $(am__objects_13) \ + $(am__objects_14) $(am__objects_15) libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) @@ -756,8 +746,7 @@ 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_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \ - $(libgfortran_la_SOURCES) +SOURCES = $(libcaf_single_la_SOURCES) $(libgfortran_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ @@ -973,28 +962,12 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(version_arg) -Wc,-shared-libgcc libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP) -libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h -libcaf_shared_SRCS = caf/caf_error.c -cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la +cafexeclib_LTLIBRARIES = libcaf_single.la cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) -libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS) +libcaf_single_la_SOURCES = caf/single.c libcaf_single_la_LDFLAGS = -static -libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS) +libcaf_single_la_DEPENDENCIES = caf/libcaf.h libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS) -libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \ - caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \ - caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \ - caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \ - caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c - -libcaf_shmem_la_LDFLAGS = -static -libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \ - caf/shmem/allocator.h caf/shmem/collective_subroutine.h \ - caf/shmem/counter_barrier.h caf/shmem/hashmap.h \ - caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \ - caf/shmem/teams_mgmt.h caf/shmem/thread_support.h - -libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS) @IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude @IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \ @@ -1991,40 +1964,9 @@ 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 @@ -3829,8 +3771,6 @@ 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) @@ -3845,19 +3785,7 @@ 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@ @@ -4622,7 +4550,6 @@ 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 @@ -4790,8 +4717,6 @@ 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) @@ -4814,7 +4739,7 @@ clean-am: clean-cafexeclibLTLIBRARIES clean-generic clean-libtool \ distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-libtool distclean-local distclean-tags @@ -4863,7 +4788,7 @@ installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache - -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic \ maintainer-clean-local diff --git a/libgfortran/caf/caf_error.c b/libgfortran/caf/caf_error.c deleted file mode 100644 index a8f3bf7f189b..000000000000 --- a/libgfortran/caf/caf_error.c +++ /dev/null @@ -1,71 +0,0 @@ -/* 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 deleted file mode 100644 index 15455377eb03..000000000000 --- a/libgfortran/caf/caf_error.h +++ /dev/null @@ -1,44 +0,0 @@ -/* 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 80ea72ff7426..7267bc76905e 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -26,6 +26,9 @@ 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 @@ -172,9 +175,12 @@ 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 *, int *); -int _gfortran_caf_image_status (int, caf_team_t *); -void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *); +void _gfortran_caf_failed_images (gfc_descriptor_t *, + caf_team_t * __attribute__ ((unused)), int *); +int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused))); +void _gfortran_caf_stopped_images (gfc_descriptor_t *, + caf_team_t * __attribute__ ((unused)), + int *); void _gfortran_caf_random_init (bool, bool); diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c deleted file mode 100644 index b8d92d657f5f..000000000000 --- a/libgfortran/caf/shmem.c +++ /dev/null @@ -1,1882 +0,0 @@ -/* 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 deleted file mode 100644 index fecf97c03ffa..000000000000 --- a/libgfortran/caf/shmem/alloc.c +++ /dev/null @@ -1,168 +0,0 @@ -/* 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 deleted file mode 100644 index d85b1a30236c..000000000000 --- a/libgfortran/caf/shmem/alloc.h +++ /dev/null @@ -1,80 +0,0 @@ -/* 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 deleted file mode 100644 index d900167cfc24..000000000000 --- a/libgfortran/caf/shmem/allocator.c +++ /dev/null @@ -1,131 +0,0 @@ -/* 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 deleted file mode 100644 index 53b6abeeba11..000000000000 --- a/libgfortran/caf/shmem/allocator.h +++ /dev/null @@ -1,88 +0,0 @@ -/* 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 deleted file mode 100644 index 257a048d63d5..000000000000 --- a/libgfortran/caf/shmem/collective_subroutine.c +++ /dev/null @@ -1,434 +0,0 @@ -/* 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 deleted file mode 100644 index 8c37186c867b..000000000000 --- a/libgfortran/caf/shmem/collective_subroutine.h +++ /dev/null @@ -1,50 +0,0 @@ -/* 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 deleted file mode 100644 index f78ba7fe852d..000000000000 --- a/libgfortran/caf/shmem/counter_barrier.c +++ /dev/null @@ -1,121 +0,0 @@ -/* 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 deleted file mode 100644 index a28c58812a54..000000000000 --- a/libgfortran/caf/shmem/counter_barrier.h +++ /dev/null @@ -1,76 +0,0 @@ -/* 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 deleted file mode 100644 index e17d6dd2dcab..000000000000 --- a/libgfortran/caf/shmem/hashmap.c +++ /dev/null @@ -1,366 +0,0 @@ -/* 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 deleted file mode 100644 index bc263d32dcd4..000000000000 --- a/libgfortran/caf/shmem/hashmap.h +++ /dev/null @@ -1,98 +0,0 @@ -/* 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 deleted file mode 100644 index 2b3666ddd3b9..000000000000 --- a/libgfortran/caf/shmem/shared_memory.c +++ /dev/null @@ -1,200 +0,0 @@ -/* 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 deleted file mode 100644 index 01ac2811e5d6..000000000000 --- a/libgfortran/caf/shmem/shared_memory.h +++ /dev/null @@ -1,93 +0,0 @@ -/* 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 deleted file mode 100644 index 9e5b794a23f0..000000000000 --- a/libgfortran/caf/shmem/supervisor.c +++ /dev/null @@ -1,311 +0,0 @@ -/* 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 deleted file mode 100644 index 7afb82696749..000000000000 --- a/libgfortran/caf/shmem/supervisor.h +++ /dev/null @@ -1,112 +0,0 @@ -/* 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 deleted file mode 100644 index a456244629ca..000000000000 --- a/libgfortran/caf/shmem/sync.c +++ /dev/null @@ -1,182 +0,0 @@ -/* 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 deleted file mode 100644 index a3e586bca244..000000000000 --- a/libgfortran/caf/shmem/sync.h +++ /dev/null @@ -1,79 +0,0 @@ -/* 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 deleted file mode 100644 index 44a34d727c36..000000000000 --- a/libgfortran/caf/shmem/teams_mgmt.c +++ /dev/null @@ -1,83 +0,0 @@ -/* 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 deleted file mode 100644 index f96f4aea33e6..000000000000 --- a/libgfortran/caf/shmem/teams_mgmt.h +++ /dev/null @@ -1,93 +0,0 @@ -/* 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 deleted file mode 100644 index 572f39400b38..000000000000 --- a/libgfortran/caf/shmem/thread_support.c +++ /dev/null @@ -1,73 +0,0 @@ -/* 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 deleted file mode 100644 index e70b4b83c7d6..000000000000 --- a/libgfortran/caf/shmem/thread_support.h +++ /dev/null @@ -1,38 +0,0 @@ -/* 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 a6576f28260c..97876fa9d8c2 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 = vsnprintf (errmsg, errmsg_len, msg, args); + int len = snprintf (errmsg, errmsg_len, msg, args); if (len >= 0 && errmsg_len > (size_t) len) memset (&errmsg[len], ' ', errmsg_len - len); } From 9ddef25c1812bf0b9c75634013b1fbcd94eca5a4 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 29 Jul 2025 10:59:18 -0700 Subject: [PATCH 3/7] 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 --- gcc/fortran/check.cc | 11 +- gcc/fortran/coarray.cc | 26 +- gcc/fortran/invoke.texi | 54 + gcc/fortran/trans-decl.cc | 7 +- gcc/fortran/trans-expr.cc | 68 +- gcc/fortran/trans-intrinsic.cc | 6 +- gcc/fortran/trans-stmt.cc | 7 +- .../gfortran.dg/coarray/alloc_comp_4.f90 | 16 +- .../gfortran.dg/coarray/atomic_2.f90 | 25 +- gcc/testsuite/gfortran.dg/coarray/caf.exp | 13 + .../gfortran.dg/coarray/co_reduce_string.f90 | 94 + .../gfortran.dg/coarray/coarray_allocated.f90 | 9 +- .../gfortran.dg/coarray/coindexed_1.f90 | 74 +- .../gfortran.dg/coarray/coindexed_3.f08 | 4 +- .../gfortran.dg/coarray/coindexed_5.f90 | 108 +- gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 1 + gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 75 +- gcc/testsuite/gfortran.dg/coarray/event_3.f08 | 4 +- gcc/testsuite/gfortran.dg/coarray/event_4.f08 | 3 +- .../gfortran.dg/coarray/failed_images_1.f08 | 2 +- .../gfortran.dg/coarray/failed_images_2.f08 | 39 +- .../gfortran.dg/coarray/image_status_1.f08 | 2 +- .../gfortran.dg/coarray/image_status_2.f08 | 32 +- gcc/testsuite/gfortran.dg/coarray/lock_2.f90 | 2 + .../gfortran.dg/coarray/poly_run_3.f90 | 8 +- .../gfortran.dg/coarray/scalar_alloc_1.f90 | 13 +- .../gfortran.dg/coarray/stopped_images_1.f08 | 2 +- .../gfortran.dg/coarray/stopped_images_2.f08 | 39 +- gcc/testsuite/gfortran.dg/coarray/sync_1.f90 | 8 +- gcc/testsuite/gfortran.dg/coarray/sync_3.f90 | 26 +- .../gfortran.dg/coarray/sync_team.f90 | 33 + .../gfortran.dg/coarray_sync_memory.f90 | 4 +- libgfortran/Makefile.am | 23 +- libgfortran/Makefile.in | 135 +- libgfortran/caf/caf_error.c | 71 + libgfortran/caf/caf_error.h | 44 + libgfortran/caf/libcaf.h | 12 +- libgfortran/caf/shmem.c | 1882 +++++++++++++++++ libgfortran/caf/shmem/alloc.c | 168 ++ libgfortran/caf/shmem/alloc.h | 80 + libgfortran/caf/shmem/allocator.c | 131 ++ libgfortran/caf/shmem/allocator.h | 88 + libgfortran/caf/shmem/collective_subroutine.c | 434 ++++ libgfortran/caf/shmem/collective_subroutine.h | 50 + libgfortran/caf/shmem/counter_barrier.c | 121 ++ libgfortran/caf/shmem/counter_barrier.h | 76 + libgfortran/caf/shmem/hashmap.c | 366 ++++ libgfortran/caf/shmem/hashmap.h | 98 + libgfortran/caf/shmem/shared_memory.c | 200 ++ libgfortran/caf/shmem/shared_memory.h | 93 + libgfortran/caf/shmem/supervisor.c | 311 +++ libgfortran/caf/shmem/supervisor.h | 112 + libgfortran/caf/shmem/sync.c | 182 ++ libgfortran/caf/shmem/sync.h | 79 + libgfortran/caf/shmem/teams_mgmt.c | 83 + libgfortran/caf/shmem/teams_mgmt.h | 93 + libgfortran/caf/shmem/thread_support.c | 73 + libgfortran/caf/shmem/thread_support.h | 38 + libgfortran/caf/single.c | 2 +- 59 files changed, 5633 insertions(+), 227 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90 create mode 100644 libgfortran/caf/caf_error.c create mode 100644 libgfortran/caf/caf_error.h create mode 100644 libgfortran/caf/shmem.c create mode 100644 libgfortran/caf/shmem/alloc.c create mode 100644 libgfortran/caf/shmem/alloc.h create mode 100644 libgfortran/caf/shmem/allocator.c create mode 100644 libgfortran/caf/shmem/allocator.h create mode 100644 libgfortran/caf/shmem/collective_subroutine.c create mode 100644 libgfortran/caf/shmem/collective_subroutine.h create mode 100644 libgfortran/caf/shmem/counter_barrier.c create mode 100644 libgfortran/caf/shmem/counter_barrier.h create mode 100644 libgfortran/caf/shmem/hashmap.c create mode 100644 libgfortran/caf/shmem/hashmap.h create mode 100644 libgfortran/caf/shmem/shared_memory.c create mode 100644 libgfortran/caf/shmem/shared_memory.h create mode 100644 libgfortran/caf/shmem/supervisor.c create mode 100644 libgfortran/caf/shmem/supervisor.h create mode 100644 libgfortran/caf/shmem/sync.c create mode 100644 libgfortran/caf/shmem/sync.h create mode 100644 libgfortran/caf/shmem/teams_mgmt.c create mode 100644 libgfortran/caf/shmem/teams_mgmt.h create mode 100644 libgfortran/caf/shmem/thread_support.c create mode 100644 libgfortran/caf/shmem/thread_support.h diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 838d523f7c40..3446c88b5019 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 ef8fd4e42d0a..c611b5399687 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 0b893e876a5d..77926fa02599 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 d5acdca719fd..2cfddfea15b7 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 0db7ba3fd52e..c5ccfaa9c904 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 (tmp) : TREE_TYPE (tmp2); - tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - gfc_add_modify (block, tmp, tmp2); + type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim); + lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, lhs_dim, rhs_dim); + + /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ + copy_coarray_desc_part (block, lhs_desc, rhs_desc); } /* Takes a derived type expression and returns the address of a temporary @@ -920,6 +965,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym, gfc_expr_attr (e)); gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), gfc_get_dtype (type)); + copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr); if (optional) parmse->expr = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr), diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index be984271d6a8..7cd95da71169 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 f10540158627..eadd40cafd89 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 2ee8ff0253d6..50b4bab1603a 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 5e1c4967248c..7eccd7b578ca 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 c1e8e8ca2b0b..1f002e08fa3f 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 000000000000..9b4c44f1ada6 --- /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 27db0e8d8ce0..ce7c6288a611 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 f90b65cb3898..8f7a83a9c996 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 7fd20851e0a9..145835d461b3 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 c35ec1093c1f..8eb646696280 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 4b45daab6493..c569390e7c62 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 81dc90b7197b..a9fecf939843 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 +associate (me => this_image(), np => num_images()) + allocate(events(np)[*]) -stat = 99 -event post (var, stat=stat) -if (stat /= 0) STOP 2 -call event_query(var, count, stat=stat) -if (count /= 1 .or. stat /= 0) STOP 3 + associate(var => events(me)) + count = -42 + call event_query (var, count) + if (count /= 0) STOP 1 -stat = 99 -event post (var[this_image()]) -call event_query(var, count) -if (count /= 2) STOP 4 + stat = 99 + event post (var, stat=stat) + if (stat /= 0) STOP 2 + call event_query(var, count, stat=stat) + if (count /= 1 .or. stat /= 0) STOP 3 -stat = 99 -event wait (var) -call event_query(var, count) -if (count /= 1) STOP 5 + count = 99 + event post (var[this_image()]) + call event_query(var, count) + if (count /= 2) STOP 4 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 2) STOP 6 + count = 99 + event wait (var) + call event_query(var, count) + if (count /= 1) STOP 5 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 3) STOP 7 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 2) STOP 6 -stat = 99 -event wait (var, until_count=2) -call event_query(var, count) -if (count /= 1) STOP 8 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 3) STOP 7 -stat = 99 -event wait (var, stat=stat, until_count=1) -if (stat /= 0) STOP 9 -call event_query(event=var, stat=stat, count=count) -if (count /= 0 .or. stat /= 0) STOP 10 + count = 99 + event wait (var, until_count=2) + call event_query(var, count) + if (count /= 1) STOP 8 + + stat = 99 + event wait (var, stat=stat, until_count=1) + if (stat /= 0) STOP 9 + count = 99 + call event_query(event=var, stat=stat, count=count) + if (count /= 0 .or. stat /= 0) STOP 10 + end associate +end associate end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index 60d3193f776d..cedf636b79b3 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 de901c01aa43..26a1f59df030 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 4898dd8a7a2f..34ae131d15f1 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 ca5fe4020d5e..78d92daf0715 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 b7ec5a6a9c97..f725f81d4aad 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 fb49289cb782..8866f2374819 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 8e96154996d4..3d445b9b5e82 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 c284a5667607..4da1b9569fe6 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 b0d27bdfb8fa..8dd7df5d4362 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 403de585b9af..7658e6bb6bbb 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 0bf4a81a7e20..dadd00ecda7a 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 8633c4aa527d..4abe5a3b5487 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 fe1e4c548c85..ceb4b19d5171 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 000000000000..a96884549a3d --- /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 c4e660b8cf72..0030d91257d5 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 4f3b30332245..f912824d208b 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 dd88f8893b7f..003c2f13362a 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 000000000000..a8f3bf7f189b --- /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 000000000000..15455377eb03 --- /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 7267bc76905e..80ea72ff7426 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 000000000000..b8d92d657f5f --- /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 000000000000..fecf97c03ffa --- /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 000000000000..d85b1a30236c --- /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 000000000000..d900167cfc24 --- /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 000000000000..53b6abeeba11 --- /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 000000000000..257a048d63d5 --- /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 000000000000..8c37186c867b --- /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 000000000000..f78ba7fe852d --- /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 000000000000..a28c58812a54 --- /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 000000000000..e17d6dd2dcab --- /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 000000000000..bc263d32dcd4 --- /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 000000000000..2b3666ddd3b9 --- /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 000000000000..01ac2811e5d6 --- /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 000000000000..9e5b794a23f0 --- /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 000000000000..7afb82696749 --- /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 000000000000..a456244629ca --- /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 000000000000..a3e586bca244 --- /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 000000000000..44a34d727c36 --- /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 000000000000..f96f4aea33e6 --- /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 000000000000..572f39400b38 --- /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 000000000000..e70b4b83c7d6 --- /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 97876fa9d8c2..a6576f28260c 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); } From cb4b73da237153871fb840a3a31a79354933a8bb Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 29 Jul 2025 15:49:57 -0700 Subject: [PATCH 4/7] Fortran: Andre's tweak gcc/fortran/ChangeLog: * coarray.cc (check_add_new_component): Don't do addition checks. --- gcc/fortran/coarray.cc | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index c611b5399687..b3271e56ad20 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -696,22 +696,6 @@ 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)) - { - /* Only allow pure and elemental function calls in a coarray - accessor, because all other may have side effects or access - pointers, which may not be possible in the accessor running on - another host. */ - for (gfc_actual_arglist *actual = e->value.function.actual; - actual; actual = actual->next) - check_add_new_component (type, actual->expr, add_data); - } - else - /* Extract the expression, evaluate it and add a temporary with its - value to the helper structure. */ check_add_new_comp_handle_array (e, type, add_data); break; case EXPR_VARIABLE: From 3cb2c2fcdf3bd2f05afea27b6ccfb4734f6f88a0 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 2 Sep 2025 15:49:09 -0700 Subject: [PATCH 5/7] Revert "Fortran: Andre's tweak" This reverts commit cb4b73da237153871fb840a3a31a79354933a8bb. --- gcc/fortran/coarray.cc | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index b3271e56ad20..c611b5399687 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -696,6 +696,22 @@ 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)) + { + /* Only allow pure and elemental function calls in a coarray + accessor, because all other may have side effects or access + pointers, which may not be possible in the accessor running on + another host. */ + for (gfc_actual_arglist *actual = e->value.function.actual; + actual; actual = actual->next) + check_add_new_component (type, actual->expr, add_data); + } + else + /* Extract the expression, evaluate it and add a temporary with its + value to the helper structure. */ check_add_new_comp_handle_array (e, type, add_data); break; case EXPR_VARIABLE: From 845d23f3ea08ba873197c275a8857eee7edad996 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Tue, 2 Sep 2025 15:52:42 -0700 Subject: [PATCH 6/7] Revert "Fortran: Recommit changes for coarray after merging." This reverts commit 9ddef25c1812bf0b9c75634013b1fbcd94eca5a4. --- gcc/fortran/check.cc | 11 +- gcc/fortran/coarray.cc | 26 +- gcc/fortran/invoke.texi | 54 - gcc/fortran/trans-decl.cc | 7 +- gcc/fortran/trans-expr.cc | 68 +- gcc/fortran/trans-intrinsic.cc | 6 +- gcc/fortran/trans-stmt.cc | 7 +- .../gfortran.dg/coarray/alloc_comp_4.f90 | 16 +- .../gfortran.dg/coarray/atomic_2.f90 | 25 +- gcc/testsuite/gfortran.dg/coarray/caf.exp | 13 - .../gfortran.dg/coarray/co_reduce_string.f90 | 94 - .../gfortran.dg/coarray/coarray_allocated.f90 | 9 +- .../gfortran.dg/coarray/coindexed_1.f90 | 74 +- .../gfortran.dg/coarray/coindexed_3.f08 | 4 +- .../gfortran.dg/coarray/coindexed_5.f90 | 108 +- gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 1 - gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 75 +- gcc/testsuite/gfortran.dg/coarray/event_3.f08 | 4 +- gcc/testsuite/gfortran.dg/coarray/event_4.f08 | 3 +- .../gfortran.dg/coarray/failed_images_1.f08 | 2 +- .../gfortran.dg/coarray/failed_images_2.f08 | 39 +- .../gfortran.dg/coarray/image_status_1.f08 | 2 +- .../gfortran.dg/coarray/image_status_2.f08 | 32 +- gcc/testsuite/gfortran.dg/coarray/lock_2.f90 | 2 - .../gfortran.dg/coarray/poly_run_3.f90 | 8 +- .../gfortran.dg/coarray/scalar_alloc_1.f90 | 13 +- .../gfortran.dg/coarray/stopped_images_1.f08 | 2 +- .../gfortran.dg/coarray/stopped_images_2.f08 | 39 +- gcc/testsuite/gfortran.dg/coarray/sync_1.f90 | 8 +- gcc/testsuite/gfortran.dg/coarray/sync_3.f90 | 26 +- .../gfortran.dg/coarray/sync_team.f90 | 33 - .../gfortran.dg/coarray_sync_memory.f90 | 4 +- libgfortran/Makefile.am | 23 +- libgfortran/Makefile.in | 135 +- libgfortran/caf/caf_error.c | 71 - libgfortran/caf/caf_error.h | 44 - libgfortran/caf/libcaf.h | 12 +- libgfortran/caf/shmem.c | 1882 ----------------- libgfortran/caf/shmem/alloc.c | 168 -- libgfortran/caf/shmem/alloc.h | 80 - libgfortran/caf/shmem/allocator.c | 131 -- libgfortran/caf/shmem/allocator.h | 88 - libgfortran/caf/shmem/collective_subroutine.c | 434 ---- libgfortran/caf/shmem/collective_subroutine.h | 50 - libgfortran/caf/shmem/counter_barrier.c | 121 -- libgfortran/caf/shmem/counter_barrier.h | 76 - libgfortran/caf/shmem/hashmap.c | 366 ---- libgfortran/caf/shmem/hashmap.h | 98 - libgfortran/caf/shmem/shared_memory.c | 200 -- libgfortran/caf/shmem/shared_memory.h | 93 - libgfortran/caf/shmem/supervisor.c | 311 --- libgfortran/caf/shmem/supervisor.h | 112 - libgfortran/caf/shmem/sync.c | 182 -- libgfortran/caf/shmem/sync.h | 79 - libgfortran/caf/shmem/teams_mgmt.c | 83 - libgfortran/caf/shmem/teams_mgmt.h | 93 - libgfortran/caf/shmem/thread_support.c | 73 - libgfortran/caf/shmem/thread_support.h | 38 - libgfortran/caf/single.c | 2 +- 59 files changed, 227 insertions(+), 5633 deletions(-) delete mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 delete mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90 delete mode 100644 libgfortran/caf/caf_error.c delete mode 100644 libgfortran/caf/caf_error.h delete mode 100644 libgfortran/caf/shmem.c delete mode 100644 libgfortran/caf/shmem/alloc.c delete mode 100644 libgfortran/caf/shmem/alloc.h delete mode 100644 libgfortran/caf/shmem/allocator.c delete mode 100644 libgfortran/caf/shmem/allocator.h delete mode 100644 libgfortran/caf/shmem/collective_subroutine.c delete mode 100644 libgfortran/caf/shmem/collective_subroutine.h delete mode 100644 libgfortran/caf/shmem/counter_barrier.c delete mode 100644 libgfortran/caf/shmem/counter_barrier.h delete mode 100644 libgfortran/caf/shmem/hashmap.c delete mode 100644 libgfortran/caf/shmem/hashmap.h delete mode 100644 libgfortran/caf/shmem/shared_memory.c delete mode 100644 libgfortran/caf/shmem/shared_memory.h delete mode 100644 libgfortran/caf/shmem/supervisor.c delete mode 100644 libgfortran/caf/shmem/supervisor.h delete mode 100644 libgfortran/caf/shmem/sync.c delete mode 100644 libgfortran/caf/shmem/sync.h delete mode 100644 libgfortran/caf/shmem/teams_mgmt.c delete mode 100644 libgfortran/caf/shmem/teams_mgmt.h delete mode 100644 libgfortran/caf/shmem/thread_support.c delete mode 100644 libgfortran/caf/shmem/thread_support.h diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 3446c88b5019..838d523f7c40 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, 1) && team_type_check (team, 1)); + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } @@ -1878,8 +1878,13 @@ 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 && (!scalar_check (team, 0) || !team_type_check (team, 0))) - return false; + if (team) + { + gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &team->where); + return false; + } if (kind) { diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index c611b5399687..ef8fd4e42d0a 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -696,23 +696,17 @@ 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)) - { - /* Only allow pure and elemental function calls in a coarray - accessor, because all other may have side effects or access - pointers, which may not be possible in the accessor running on - another host. */ - for (gfc_actual_arglist *actual = e->value.function.actual; - actual; actual = actual->next) - check_add_new_component (type, actual->expr, add_data); - } - else - /* Extract the expression, evaluate it and add a temporary with its - value to the helper structure. */ + if (!e->symtree->n.sym->attr.pure + && !e->symtree->n.sym->attr.elemental + && !(e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental))) + /* Treat non-pure/non-elemental functions. */ check_add_new_comp_handle_array (e, type, add_data); + else + for (gfc_actual_arglist *actual = e->value.function.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, add_data); break; case EXPR_VARIABLE: check_add_new_comp_handle_array (e, type, add_data); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 77926fa02599..0b893e876a5d 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -104,7 +104,6 @@ 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 @@ -2281,56 +2280,3 @@ 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 2cfddfea15b7..d5acdca719fd 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4223,9 +4223,10 @@ 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, pvoid_type_node); + gfor_fndecl_caf_team_number + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_team_number")), ". r ", + integer_type_node, 1, integer_type_node); gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX ("caf_image_status")), ". r r ", diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index c5ccfaa9c904..0db7ba3fd52e 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -90,8 +90,6 @@ 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; @@ -102,16 +100,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr) if (POINTER_TYPE_P (TREE_TYPE (scalar))) scalar = TREE_TYPE (scalar); - if (TYPE_LANG_SPECIFIC (TREE_TYPE (scalar))) - { - struct lang_type *lang_specific = TYPE_LANG_SPECIFIC (TREE_TYPE (scalar)); - codim = lang_specific->corank; - lbound = lang_specific->lbound; - ubound = lang_specific->ubound; - } - return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, codim, lbound, - ubound, 1, akind, - !(attr.pointer || attr.target)); + return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1, + akind, !(attr.pointer || attr.target)); } tree @@ -791,43 +781,11 @@ 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 lhs_dim, rhs_dim, type; + tree tmp, tmp2, type; gfc_conv_descriptor_data_set (block, lhs_desc, gfc_conv_descriptor_data_get (rhs_desc)); @@ -838,18 +796,15 @@ 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. */ - lhs_dim = gfc_get_descriptor_dimension (lhs_desc); - rhs_dim = gfc_get_descriptor_dimension (rhs_desc); + tmp = gfc_get_descriptor_dimension (lhs_desc); + tmp2 = 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); - - /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ - copy_coarray_desc_part (block, lhs_desc, rhs_desc); + type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, tmp, tmp2); } /* Takes a derived type expression and returns the address of a temporary @@ -965,7 +920,6 @@ 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 7cd95da71169..be984271d6a8 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2073,13 +2073,9 @@ 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 - : gfc_build_addr_expr (NULL_TREE, args[1])); + num_args < 2 ? null_pointer_node : args[1]); else gcc_unreachable (); diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index eadd40cafd89..f10540158627 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1362,8 +1362,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, code->expr1); - images = gfc_trans_force_lval (&argse.pre, argse.expr); - gfc_add_block_to_block (&se.pre, &argse.pre); + images = argse.expr; } if (code->expr2) @@ -1373,7 +1372,6 @@ 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; @@ -1386,9 +1384,8 @@ 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 = argse.expr; + errmsg = gfc_build_addr_expr (NULL, argse.expr); errmsglen = fold_convert (size_type_node, argse.string_length); - gfc_add_block_to_block (&se.pre, &argse.pre); } else if (flag_coarray == GFC_FCOARRAY_LIB) { diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 index 50b4bab1603a..2ee8ff0253d6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 @@ -11,19 +11,11 @@ program main end type type(mytype), save :: object[*] - integer :: me, other + integer :: me me=this_image() - other = me + 1 - if (other .GT. num_images()) other = 1 - if (me == num_images()) then - allocate(object%indices(me/2)) - else - allocate(object%indices(me)) - end if - object%indices = 42 * me + allocate(object%indices(me)) + object%indices = 42 - sync all - if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1 - sync all + if ( any( object[me]%indices(:) /= 42 ) ) STOP 1 end program diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 index 7eccd7b578ca..5e1c4967248c 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() * 2) STOP 12 +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12 do i = 1, num_images() call atomic_ref(var, caf[i], stat=stat) if (stat /= 0 .or. var /= num_images() + i) STOP 13 @@ -328,7 +328,7 @@ end do sync all call atomic_ref(var, caf[num_images()], stat=stat) -if (stat /= 0 .or. var /= num_images() * 2) STOP 45 +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45 do i = 1, num_images() call atomic_ref(var, caf[i], stat=stat) if (stat /= 0 .or. var /= num_images() + i) STOP 46 @@ -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) STOP 53 + if (stat /= 0 .or. var <= 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) STOP 68 + if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68 end do end if sync all @@ -628,27 +628,26 @@ sync all if (this_image() == 1) then call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 82 call atomic_ref(var2, caf_log[num_images()], stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 83 end if sync all -if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84 +if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84 call atomic_ref(var2, caf_log[num_images()], stat=stat) -if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85 +if (stat /= 0 .or. var2 .neqv. .true.) STOP 85 sync all if (this_image() == 1) then call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat) - if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86 + if (stat /= 0 .or. var2 .neqv. .true.) STOP 86 call atomic_ref(var2, caf_log[num_images()], stat=stat) - if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87 + if (stat /= 0 .or. var2 .neqv. .false.) STOP 87 end if sync all -if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88 +if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88 call atomic_ref(var2, caf_log[num_images()], stat=stat) -if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89 -sync all +if (stat /= 0 .or. var2 .neqv. .false.) STOP 89 end diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp index 1f002e08fa3f..c1e8e8ca2b0b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/caf.exp +++ b/gcc/testsuite/gfortran.dg/coarray/caf.exp @@ -70,12 +70,6 @@ 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. @@ -109,13 +103,6 @@ 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 deleted file mode 100644 index 9b4c44f1ada6..000000000000 --- a/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 +++ /dev/null @@ -1,94 +0,0 @@ -!{ 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 ce7c6288a611..27db0e8d8ce0 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,1,1])) stop 4 + if (allocated (c%x[1,2,3])) stop 4 ! Allocate collectively allocate(a[*]) @@ -28,17 +28,16 @@ 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,1,1])) stop 8 + if (.not. allocated (c%x[1,2,3])) stop 8 - sync all - ! Dellocate collectively + ! Deallocate collectively deallocate(a) deallocate(c%x) if (allocated (a)) stop 9 if (allocated (c%x)) stop 10 if (allocated (a[1])) stop 11 - if (allocated (c%x[1,1,1])) stop 12 + if (allocated (c%x[1,2,3])) stop 12 end ! Expected: always local access and never a call to _gfortran_caf_get diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 index 8f7a83a9c996..f90b65cb3898 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 @@ -21,7 +21,6 @@ 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 @@ -38,7 +37,6 @@ 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 @@ -55,7 +53,6 @@ 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 @@ -72,7 +69,6 @@ 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 @@ -95,7 +91,6 @@ 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 @@ -118,7 +113,6 @@ 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 @@ -141,7 +135,6 @@ 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 @@ -164,7 +157,6 @@ 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 @@ -187,7 +179,6 @@ 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 @@ -208,7 +199,6 @@ 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 @@ -229,7 +219,6 @@ 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 @@ -250,7 +239,6 @@ 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 @@ -273,7 +261,6 @@ 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 @@ -290,7 +277,6 @@ 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 @@ -307,7 +293,6 @@ 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 @@ -324,7 +309,6 @@ 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 @@ -347,7 +331,6 @@ 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 @@ -370,7 +353,6 @@ 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 @@ -393,7 +375,6 @@ 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 @@ -416,7 +397,6 @@ 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 @@ -439,7 +419,6 @@ 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 @@ -460,7 +439,6 @@ 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 @@ -481,7 +459,6 @@ 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 @@ -502,7 +479,6 @@ 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 @@ -526,7 +502,6 @@ 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 @@ -543,7 +518,6 @@ 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 @@ -560,7 +534,6 @@ 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 @@ -577,7 +550,6 @@ 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 @@ -600,7 +572,6 @@ 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 @@ -623,7 +594,6 @@ 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 @@ -646,7 +616,6 @@ 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 @@ -669,7 +638,6 @@ 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 @@ -692,7 +660,6 @@ 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 @@ -713,7 +680,6 @@ 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 @@ -734,7 +700,6 @@ 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 @@ -755,7 +720,6 @@ 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 @@ -779,8 +743,7 @@ subroutine char_test() str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" ustr1a = 4_"abc" - str2a = 1_"XXXXXXX" - sync all + str1a = 1_"XXXXXXX" if (this_image() == num_images()) then str2a[1] = ustr1a end if @@ -797,7 +760,6 @@ 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 @@ -814,7 +776,6 @@ 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 @@ -831,7 +792,6 @@ 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 @@ -854,7 +814,6 @@ 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 @@ -877,7 +836,6 @@ 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 @@ -900,7 +858,6 @@ 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 @@ -923,7 +880,6 @@ 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 @@ -946,7 +902,6 @@ 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 @@ -967,7 +922,6 @@ 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 @@ -988,7 +942,6 @@ 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 @@ -1009,7 +962,6 @@ 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 @@ -1032,7 +984,6 @@ 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 @@ -1049,7 +1000,6 @@ 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 @@ -1066,7 +1016,6 @@ 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 @@ -1083,7 +1032,6 @@ 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 @@ -1106,7 +1054,6 @@ 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 @@ -1129,7 +1076,6 @@ 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 @@ -1152,7 +1098,6 @@ 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 @@ -1175,7 +1120,6 @@ 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 @@ -1198,7 +1142,6 @@ 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 @@ -1219,7 +1162,6 @@ 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 @@ -1240,7 +1182,6 @@ 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 @@ -1261,7 +1202,6 @@ 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 @@ -1285,7 +1225,6 @@ 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 @@ -1302,7 +1241,6 @@ 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 @@ -1319,7 +1257,6 @@ 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 @@ -1336,7 +1273,6 @@ 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 @@ -1359,7 +1295,6 @@ 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 @@ -1382,7 +1317,6 @@ 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 @@ -1405,7 +1339,6 @@ 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 @@ -1428,7 +1361,6 @@ 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 @@ -1451,7 +1383,6 @@ 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 @@ -1472,7 +1403,6 @@ 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 @@ -1493,7 +1423,6 @@ 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 @@ -1514,7 +1443,6 @@ 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 145835d461b3..7fd20851e0a9 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 - sync all - + ! Checking against single image only. Therefore team statements are + ! not viable nor are they (yet) supported by GFortran. if (a[1, team_number=-1, stat=s] /= 42) stop 1 if (s /= 0) stop 2 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 index 8eb646696280..c35ec1093c1f 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -13,72 +13,68 @@ program coindexed_5 parentteam = get_team() caf = [23, 32] - form team(t_num, team) !, new_index=num_images() - this_image() + 1) + form team(t_num, team, new_index=1) form team(t_num, formed_team) change team(team, cell[*] => caf(2)) - associate(me => this_image()) - ! for get_from_remote - ! Checking against caf_single is very limitted. - if (cell[me, team_number=t_num] /= 32) stop 1 - if (cell[me, team_number=st_num] /= 32) stop 2 - if (cell[me, team=parentteam] /= 32) stop 3 + ! for get_from_remote + ! Checking against caf_single is very limitted. + if (cell[1, team_number=t_num] /= 32) stop 1 + if (cell[1, team_number=st_num] /= 32) stop 2 + if (cell[1, team=parentteam] /= 32) stop 3 - ! Check that team_number is validated - lhs = cell[me, team_number=5, stat=stat] - if (stat /= 1) stop 4 + ! Check that team_number is validated + lhs = cell[1, team_number=5, stat=stat] + if (stat /= 1) stop 4 - ! Check that only access to active teams is valid - stat = 42 - lhs = cell[me, team=formed_team, stat=stat] - if (stat /= 1) stop 5 + ! Check that only access to active teams is valid + stat = 42 + lhs = cell[1, team=formed_team, stat=stat] + if (stat /= 1) stop 5 - ! for send_to_remote - ! Checking against caf_single is very limitted. - cell[me, team_number=t_num] = 45 - if (cell /= 45) stop 11 - cell[me, team_number=st_num] = 46 - if (cell /= 46) stop 12 - cell[me, team=parentteam] = 47 - if (cell /= 47) stop 13 + ! for send_to_remote + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = 45 + if (cell /= 45) stop 11 + cell[1, team_number=st_num] = 46 + if (cell /= 46) stop 12 + cell[1, team=parentteam] = 47 + if (cell /= 47) stop 13 - ! Check that team_number is validated - stat = -1 - cell[me, team_number=5, stat=stat] = 0 - if (stat /= 1) stop 14 + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = 0 + if (stat /= 1) stop 14 - ! Check that only access to active teams is valid - stat = 42 - cell[me, team=formed_team, stat=stat] = -1 - if (stat /= 1) stop 15 + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = -1 + if (stat /= 1) stop 15 - ! for transfer_between_remotes - ! Checking against caf_single is very limitted. - cell[me, team_number=t_num] = caf(1)[me, team_number=-1] - if (cell /= 23) stop 21 - cell[me, team_number=st_num] = caf(2)[me, team_number=-1] - ! cell is an alias for caf(2) and has been overwritten by caf(1)! - if (cell /= 23) stop 22 - cell[me, team=parentteam] = caf(1)[me, team= team] - if (cell /= 23) stop 23 + ! for transfer_between_remotes + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = caf(1)[1, team_number=-1] + if (cell /= 23) stop 21 + cell[1, team_number=st_num] = caf(2)[1, team_number=-1] + ! cell is an alias for caf(2) and has been overwritten by caf(1)! + if (cell /= 23) stop 22 + cell[1, team=parentteam] = caf(1)[1, team= team] + if (cell /= 23) stop 23 - ! Check that team_number is validated - stat = -1 - cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1] - if (stat /= 1) stop 24 - stat = -1 - cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat] - if (stat /= 1) stop 25 + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1] + if (stat /= 1) stop 24 + stat = -1 + cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat] + if (stat /= 1) stop 25 - ! Check that only access to active teams is valid - stat = 42 - cell[me, team=formed_team, stat=stat] = caf(1)[me] - if (stat /= 1) stop 26 - stat = 42 - cell[me] = caf(1)[me, team=formed_team, stat=stat] - if (stat /= 1) stop 27 - - sync all - end associate + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = caf(1)[1] + if (stat /= 1) stop 26 + stat = 42 + cell[1] = caf(1)[1, team=formed_team, stat=stat] + if (stat /= 1) stop 27 end team end program coindexed_5 diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 index c569390e7c62..4b45daab6493 100644 --- a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 @@ -15,7 +15,6 @@ 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 a9fecf939843..81dc90b7197b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 @@ -5,54 +5,47 @@ use iso_fortran_env, only: event_type implicit none -type(event_type), save, allocatable, dimension(:) :: events[:] +type(event_type), save :: var[*] integer :: count, stat -associate (me => this_image(), np => num_images()) - allocate(events(np)[*]) +count = -42 +call event_query (var, count) +if (count /= 0) STOP 1 - 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 - 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 - count = 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 - count = 99 - event wait (var) - call event_query(var, count) - if (count /= 1) STOP 5 +stat = 99 +event post (var) +call event_query(var, count) +if (count /= 2) STOP 6 - count = 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 - count = 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 - 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 +stat = 99 +event wait (var, stat=stat, until_count=1) +if (stat /= 0) STOP 9 +call event_query(event=var, stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 10 end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index cedf636b79b3..60d3193f776d 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[this_image()]) - event post(x[this_image()]) + event post(x[1]) + event post(x[1]) call event_query(x, cnt) if (cnt /= 2) error stop 1 event wait(x, until_count=2) diff --git a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 index 26a1f59df030..de901c01aa43 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 @@ -8,6 +8,5 @@ program event_4 type(event_type) done[*] nc(1) = 1 event post(done[1]) - if (this_image() == 1) event wait(done,until_count=nc(1)) - sync all + event wait(done,until_count=nc(1)) end diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 index 34ae131d15f1..4898dd8a7a2f 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\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" } + fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" } fi = failed_images(KIND=1) ! OK fi = failed_images(KIND=4) ! OK fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" } diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 index 78d92daf0715..ca5fe4020d5e 100644 --- a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 @@ -1,44 +1,17 @@ ! { dg-do run } program test_failed_images_2 - use iso_fortran_env implicit none - type(team_type) :: t integer, allocatable :: fi(:) integer(kind=1), allocatable :: sfi(:) - integer, allocatable :: rem_images(:) - integer :: i, st - associate(np => num_images()) - form team (1, t) - fi = failed_images() - if (size(fi) > 0) stop 1 - sfi = failed_images(KIND=1) - if (size(sfi) > 0) stop 2 - sfi = failed_images(KIND=8) - if (size(sfi) > 0) stop 3 - - fi = failed_images(t) - if (size(fi) > 0) stop 4 + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" - if (num_images() > 1) then - sync all - if (this_image() == 2) fail image - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on a failed image. Try with a sleep. - do i = 0, 10 - if (size(failed_images()) == 0) then - call sleep(1) - else - exit - end if - end do - if (i == 10 .AND. size(failed_images()) == 0) stop 5 - sync images (rem_images, stat=st) - if (any(failed_images() /= [2])) stop 6 - if (any(failed_images(t, 8) /= [2])) stop 7 - end if - end associate end program test_failed_images_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index f725f81d4aad..b7ec5a6a9c97 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 "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" } + isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" } isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 index 8866f2374819..fb49289cb782 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 @@ -1,38 +1,12 @@ ! { dg-do run } program test_image_status_2 - use iso_fortran_env + use iso_fortran_env , only : STAT_STOPPED_IMAGE implicit none - type(team_type) :: t - integer :: i, st - integer, allocatable :: rem_images(:) - - form team (1, t) - if (image_status(1) /= 0) error stop "Image 1 should report OK." - if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped." - - if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK." - - if (num_images() > 1) then - associate (np => num_images()) - sync all - if (this_image() == 2) fail image - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on failed image. Try with a sleep. - do i = 0, 10 - if (image_status(2) /= STAT_FAILED_IMAGE) then - call sleep(1) - else - exit - end if - end do - sync images (rem_images, stat=st) - if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed." - if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed." - end associate - end if + if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped." + if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped." end program test_image_status_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 index 3d445b9b5e82..8e96154996d4 100644 --- a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 @@ -58,8 +58,6 @@ 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 4da1b9569fe6..c284a5667607 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) /= num_images())) STOP 3 +if (any (ucobound(a) /= this_image())) STOP 3 deallocate(a) allocate(b[*]) if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) & STOP 4 if (any (lcobound(b) /= 1)) STOP 5 -if (any (ucobound(b) /= num_images())) STOP 6 +if (any (ucobound(b) /= this_image())) STOP 6 deallocate(b) allocate(a(1)[-10:*]) if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & STOP 7 if (any (lcobound(a) /= -10)) STOP 8 -if (any (ucobound(a) /= -11 + num_images())) STOP 9 +if (any (ucobound(a) /= -11+this_image())) STOP 9 deallocate(a) allocate(d[23:*]) if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) & STOP 10 if (any (lcobound(d) /= 23)) STOP 11 -if (any (ucobound(d) /= 22 + num_images())) STOP 12 +if (any (ucobound(d) /= 22+this_image())) STOP 12 deallocate(d) end diff --git a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 index 8dd7df5d4362..b0d27bdfb8fa 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 () + 3] = 8 - 2*this_image () +a[this_image ()] = 8 - 2*this_image () if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) & STOP 4 @@ -30,7 +30,6 @@ 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 @@ -48,8 +47,7 @@ contains STOP 8 if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) & STOP 9 - if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10 - sync all + if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3 deallocate(x) end subroutine sub @@ -58,13 +56,12 @@ contains integer, allocatable, SAVE :: a[:] if (init) then - if (allocated(a)) STOP 11 + if (allocated(a)) STOP 10 allocate(a[*]) a = 45 else - if (.not. allocated(a)) STOP 12 - if (a /= 45) STOP 13 - sync all + if (.not. allocated(a)) STOP 11 + if (a /= 45) STOP 12 deallocate(a) end if end subroutine two diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 index 7658e6bb6bbb..403de585b9af 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\\) shall be of type 'team_type' from the intrinsic module 'ISO_FORTRAN_ENV'" } + gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" } gi = stopped_images(KIND=1) ! OK gi = stopped_images(KIND=4) ! OK gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" } diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 index dadd00ecda7a..0bf4a81a7e20 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 @@ -1,44 +1,17 @@ ! { dg-do run } program test_stopped_images_2 - use iso_fortran_env implicit none - type(team_type) :: t integer, allocatable :: si(:) integer(kind=1), allocatable :: ssi(:) - integer, allocatable :: rem_images(:) - integer :: i, st - associate(np => num_images()) - form team (1, t) - si = stopped_images() - if (size(si) > 0) stop 1 - ssi = stopped_images(KIND=1) - if (size(ssi) > 0) stop 2 - ssi = stopped_images(KIND=8) - if (size(ssi) > 0) stop 3 - - si = stopped_images(t) - if (size(si) > 0) stop 4 + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" - if (num_images() > 1) then - sync all - if (this_image() == 2) stop - rem_images = (/ 1, ( i, i = 3, np )/) - ! Can't synchronize well on a stopped image. Try with a sleep. - do i = 0, 10 - if (size(stopped_images()) == 0) then - call sleep(1) - else - exit - end if - end do - if (i == 10 .AND. size(stopped_images()) == 0) stop 5 - sync images (rem_images, stat=st) - if (any(stopped_images() /= [2])) stop 6 - if (any(stopped_images(t, 8) /= [2])) stop 7 - end if - end associate end program test_stopped_images_2 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 index 4abe5a3b5487..8633c4aa527d 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 @@ -26,6 +26,7 @@ n = 5 sync all (stat=n,errmsg=str) if (n /= 0) STOP 2 + ! ! Test SYNC MEMORY ! @@ -41,21 +42,17 @@ 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 @@ -64,5 +61,4 @@ 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 ceb4b19d5171..fe1e4c548c85 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 @@ -9,9 +9,8 @@ ! PR fortran/18918 implicit none -integer :: n, st -integer,allocatable :: others(:) -character(len=40) :: str +integer :: n +character(len=30) :: str critical end critical myCr: critical @@ -59,32 +58,17 @@ 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 -st = 0 -sync images (n, errmsg=str, stat=st) -if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7 - -! Do this only on image 1, or output of error messages will clutter -if (this_image() == 1) sync images (n) ! Invalid: "-1" +sync images ( num_images() ) +sync images (n) ! Invalid: "-1" end diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 deleted file mode 100644 index a96884549a3d..000000000000 --- a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 +++ /dev/null @@ -1,33 +0,0 @@ -!{ 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 0030d91257d5..c4e660b8cf72 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 f912824d208b..4f3b30332245 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -58,30 +58,13 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(version_arg) -Wc,-shared-libgcc libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP) -libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h -libcaf_shared_SRCS = caf/caf_error.c - -cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la +cafexeclib_LTLIBRARIES = libcaf_single.la cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) -libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS) +libcaf_single_la_SOURCES = caf/single.c libcaf_single_la_LDFLAGS = -static -libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS) +libcaf_single_la_DEPENDENCIES = caf/libcaf.h libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS) -libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \ - caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \ - caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \ - caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \ - caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c - -libcaf_shmem_la_LDFLAGS = -static -libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \ - caf/shmem/allocator.h caf/shmem/collective_subroutine.h \ - caf/shmem/counter_barrier.h caf/shmem/hashmap.h \ - caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \ - caf/shmem/teams_mgmt.h caf/shmem/thread_support.h -libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS) - if IEEE_SUPPORT fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 003c2f13362a..dd88f8893b7f 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -217,31 +217,21 @@ am__installdirs = "$(DESTDIR)$(cafexeclibdir)" \ "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)" \ "$(DESTDIR)$(gfor_cdir)" "$(DESTDIR)$(fincludedir)" LTLIBRARIES = $(cafexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES) -libcaf_shmem_la_LIBADD = -am__dirstamp = $(am__leading_dot)dirstamp -am__objects_1 = caf/caf_error.lo -am_libcaf_shmem_la_OBJECTS = $(am__objects_1) caf/shmem.lo \ - caf/shmem/alloc.lo caf/shmem/allocator.lo \ - caf/shmem/collective_subroutine.lo \ - caf/shmem/counter_barrier.lo caf/shmem/hashmap.lo \ - caf/shmem/shared_memory.lo caf/shmem/supervisor.lo \ - caf/shmem/sync.lo caf/shmem/teams_mgmt.lo \ - caf/shmem/thread_support.lo -libcaf_shmem_la_OBJECTS = $(am_libcaf_shmem_la_OBJECTS) libcaf_single_la_LIBADD = -am_libcaf_single_la_OBJECTS = caf/single.lo $(am__objects_1) +am__dirstamp = $(am__leading_dot)dirstamp +am_libcaf_single_la_OBJECTS = caf/single.lo libcaf_single_la_OBJECTS = $(am_libcaf_single_la_OBJECTS) libgfortran_la_LIBADD = -@LIBGFOR_MINIMAL_TRUE@am__objects_2 = runtime/minimal.lo -@LIBGFOR_MINIMAL_FALSE@am__objects_3 = runtime/backtrace.lo \ +@LIBGFOR_MINIMAL_TRUE@am__objects_1 = runtime/minimal.lo +@LIBGFOR_MINIMAL_FALSE@am__objects_2 = runtime/backtrace.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/convert_char.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/environ.lo runtime/error.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/fpu.lo runtime/main.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/pause.lo runtime/stop.lo -am__objects_4 = runtime/bounds.lo runtime/compile_options.lo \ +am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \ runtime/memory.lo runtime/string.lo runtime/select.lo \ - $(am__objects_2) $(am__objects_3) -am__objects_5 = generated/matmul_i1.lo generated/matmul_i2.lo \ + $(am__objects_1) $(am__objects_2) +am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \ generated/matmul_i4.lo generated/matmul_i8.lo \ generated/matmul_i16.lo generated/matmul_r4.lo \ generated/matmul_r8.lo generated/matmul_r10.lo \ @@ -249,9 +239,9 @@ am__objects_5 = 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_6 = generated/matmul_l4.lo generated/matmul_l8.lo \ +am__objects_5 = generated/matmul_l4.lo generated/matmul_l8.lo \ generated/matmul_l16.lo -am__objects_7 = generated/matmulavx128_i1.lo \ +am__objects_6 = generated/matmulavx128_i1.lo \ generated/matmulavx128_i2.lo generated/matmulavx128_i4.lo \ generated/matmulavx128_i8.lo generated/matmulavx128_i16.lo \ generated/matmulavx128_r4.lo generated/matmulavx128_r8.lo \ @@ -259,7 +249,7 @@ am__objects_7 = 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_8 = generated/all_l1.lo generated/all_l2.lo \ +am__objects_7 = generated/all_l1.lo generated/all_l2.lo \ generated/all_l4.lo generated/all_l8.lo generated/all_l16.lo \ generated/any_l1.lo generated/any_l2.lo generated/any_l4.lo \ generated/any_l8.lo generated/any_l16.lo \ @@ -548,17 +538,17 @@ am__objects_8 = 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_5) $(am__objects_6) $(am__objects_7) \ + $(am__objects_4) $(am__objects_5) $(am__objects_6) \ runtime/ISO_Fortran_binding.lo -@LIBGFOR_MINIMAL_FALSE@am__objects_9 = io/close.lo io/file_pos.lo \ +@LIBGFOR_MINIMAL_FALSE@am__objects_8 = io/close.lo io/file_pos.lo \ @LIBGFOR_MINIMAL_FALSE@ io/format.lo io/inquire.lo \ @LIBGFOR_MINIMAL_FALSE@ io/intrinsics.lo io/list_read.lo \ @LIBGFOR_MINIMAL_FALSE@ io/lock.lo io/open.lo io/read.lo \ @LIBGFOR_MINIMAL_FALSE@ io/transfer.lo io/transfer128.lo \ @LIBGFOR_MINIMAL_FALSE@ io/unit.lo io/unix.lo io/write.lo \ @LIBGFOR_MINIMAL_FALSE@ io/fbuf.lo io/async.lo -am__objects_10 = io/size_from_kind.lo $(am__objects_9) -@LIBGFOR_MINIMAL_FALSE@am__objects_11 = intrinsics/access.lo \ +am__objects_9 = io/size_from_kind.lo $(am__objects_8) +@LIBGFOR_MINIMAL_FALSE@am__objects_10 = intrinsics/access.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/c99_functions.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/chdir.lo intrinsics/chmod.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/clock.lo \ @@ -582,8 +572,8 @@ am__objects_10 = io/size_from_kind.lo $(am__objects_9) @LIBGFOR_MINIMAL_FALSE@ intrinsics/system_clock.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/time.lo intrinsics/umask.lo \ @LIBGFOR_MINIMAL_FALSE@ intrinsics/unlink.lo -@IEEE_SUPPORT_TRUE@am__objects_12 = ieee/ieee_helper.lo -am__objects_13 = intrinsics/associated.lo intrinsics/abort.lo \ +@IEEE_SUPPORT_TRUE@am__objects_11 = ieee/ieee_helper.lo +am__objects_12 = intrinsics/associated.lo intrinsics/abort.lo \ intrinsics/args.lo intrinsics/cshift0.lo \ intrinsics/eoshift0.lo intrinsics/eoshift2.lo \ intrinsics/erfc_scaled.lo intrinsics/extends_type_of.lo \ @@ -598,12 +588,12 @@ am__objects_13 = 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_11) $(am__objects_12) -@IEEE_SUPPORT_TRUE@am__objects_14 = ieee/ieee_arithmetic.lo \ + runtime/in_unpack_class.lo $(am__objects_10) $(am__objects_11) +@IEEE_SUPPORT_TRUE@am__objects_13 = ieee/ieee_arithmetic.lo \ @IEEE_SUPPORT_TRUE@ ieee/ieee_exceptions.lo \ @IEEE_SUPPORT_TRUE@ ieee/ieee_features.lo -am__objects_15 = -am__objects_16 = generated/_abs_c4.lo generated/_abs_c8.lo \ +am__objects_14 = +am__objects_15 = generated/_abs_c4.lo generated/_abs_c8.lo \ generated/_abs_c10.lo generated/_abs_c16.lo \ generated/_abs_c17.lo generated/_abs_i4.lo \ generated/_abs_i8.lo generated/_abs_i16.lo \ @@ -689,9 +679,9 @@ am__objects_16 = 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_4) $(am__objects_8) \ - $(am__objects_10) $(am__objects_13) $(am__objects_14) \ - $(am__objects_15) $(am__objects_16) +am_libgfortran_la_OBJECTS = $(am__objects_3) $(am__objects_7) \ + $(am__objects_9) $(am__objects_12) $(am__objects_13) \ + $(am__objects_14) $(am__objects_15) libgfortran_la_OBJECTS = $(am_libgfortran_la_OBJECTS) AM_V_P = $(am__v_P_@AM_V@) am__v_P_ = $(am__v_P_@AM_DEFAULT_V@) @@ -756,8 +746,7 @@ 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_shmem_la_SOURCES) $(libcaf_single_la_SOURCES) \ - $(libgfortran_la_SOURCES) +SOURCES = $(libcaf_single_la_SOURCES) $(libgfortran_la_SOURCES) am__can_run_installinfo = \ case $$AM_UPDATE_INFO_DIR in \ n|no|NO) false;; \ @@ -973,28 +962,12 @@ libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(version_arg) -Wc,-shared-libgcc libgfortran_la_DEPENDENCIES = $(version_dep) libgfortran.spec $(LIBQUADLIB_DEP) -libcaf_shared_DEPS = caf/libcaf.h caf/caf_error.h -libcaf_shared_SRCS = caf/caf_error.c -cafexeclib_LTLIBRARIES = libcaf_single.la libcaf_shmem.la +cafexeclib_LTLIBRARIES = libcaf_single.la cafexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) -libcaf_single_la_SOURCES = caf/single.c $(libcaf_shared_SRCS) +libcaf_single_la_SOURCES = caf/single.c libcaf_single_la_LDFLAGS = -static -libcaf_single_la_DEPENDENCIES = $(libcaf_shared_DEPS) +libcaf_single_la_DEPENDENCIES = caf/libcaf.h libcaf_single_la_LINK = $(LINK) $(libcaf_single_la_LDFLAGS) -libcaf_shmem_la_SOURCES = $(libcaf_shared_SRCS) \ - caf/shmem.c caf/shmem/alloc.c caf/shmem/allocator.c \ - caf/shmem/collective_subroutine.c caf/shmem/counter_barrier.c \ - caf/shmem/hashmap.c caf/shmem/shared_memory.c caf/shmem/supervisor.c \ - caf/shmem/sync.c caf/shmem/teams_mgmt.c caf/shmem/thread_support.c - -libcaf_shmem_la_LDFLAGS = -static -libcaf_shmem_la_DEPENDENCIES = $(libcaf_shared_DEPS) caf/shmem/alloc.h \ - caf/shmem/allocator.h caf/shmem/collective_subroutine.h \ - caf/shmem/counter_barrier.h caf/shmem/hashmap.h \ - caf/shmem/shared_memory.h caf/shmem/supervisor.h caf/shmem/sync.h \ - caf/shmem/teams_mgmt.h caf/shmem/thread_support.h - -libcaf_shmem_la_LINK = $(LINK) $(libcaf_shmem_la_LDFLAGS) @IEEE_SUPPORT_TRUE@fincludedir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR)/finclude @IEEE_SUPPORT_TRUE@nodist_finclude_HEADERS = ieee_arithmetic.mod ieee_exceptions.mod ieee_features.mod AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \ @@ -1991,40 +1964,9 @@ 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 @@ -3829,8 +3771,6 @@ 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) @@ -3845,19 +3785,7 @@ 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@ @@ -4622,7 +4550,6 @@ 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 @@ -4790,8 +4717,6 @@ 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) @@ -4814,7 +4739,7 @@ clean-am: clean-cafexeclibLTLIBRARIES clean-generic clean-libtool \ distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-libtool distclean-local distclean-tags @@ -4863,7 +4788,7 @@ installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache - -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic \ maintainer-clean-local diff --git a/libgfortran/caf/caf_error.c b/libgfortran/caf/caf_error.c deleted file mode 100644 index a8f3bf7f189b..000000000000 --- a/libgfortran/caf/caf_error.c +++ /dev/null @@ -1,71 +0,0 @@ -/* 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 deleted file mode 100644 index 15455377eb03..000000000000 --- a/libgfortran/caf/caf_error.h +++ /dev/null @@ -1,44 +0,0 @@ -/* 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 80ea72ff7426..7267bc76905e 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -26,6 +26,9 @@ 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 @@ -172,9 +175,12 @@ 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 *, int *); -int _gfortran_caf_image_status (int, caf_team_t *); -void _gfortran_caf_stopped_images (gfc_descriptor_t *, caf_team_t *, int *); +void _gfortran_caf_failed_images (gfc_descriptor_t *, + caf_team_t * __attribute__ ((unused)), int *); +int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused))); +void _gfortran_caf_stopped_images (gfc_descriptor_t *, + caf_team_t * __attribute__ ((unused)), + int *); void _gfortran_caf_random_init (bool, bool); diff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c deleted file mode 100644 index b8d92d657f5f..000000000000 --- a/libgfortran/caf/shmem.c +++ /dev/null @@ -1,1882 +0,0 @@ -/* 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 deleted file mode 100644 index fecf97c03ffa..000000000000 --- a/libgfortran/caf/shmem/alloc.c +++ /dev/null @@ -1,168 +0,0 @@ -/* 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 deleted file mode 100644 index d85b1a30236c..000000000000 --- a/libgfortran/caf/shmem/alloc.h +++ /dev/null @@ -1,80 +0,0 @@ -/* 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 deleted file mode 100644 index d900167cfc24..000000000000 --- a/libgfortran/caf/shmem/allocator.c +++ /dev/null @@ -1,131 +0,0 @@ -/* 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 deleted file mode 100644 index 53b6abeeba11..000000000000 --- a/libgfortran/caf/shmem/allocator.h +++ /dev/null @@ -1,88 +0,0 @@ -/* 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 deleted file mode 100644 index 257a048d63d5..000000000000 --- a/libgfortran/caf/shmem/collective_subroutine.c +++ /dev/null @@ -1,434 +0,0 @@ -/* 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 deleted file mode 100644 index 8c37186c867b..000000000000 --- a/libgfortran/caf/shmem/collective_subroutine.h +++ /dev/null @@ -1,50 +0,0 @@ -/* 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 deleted file mode 100644 index f78ba7fe852d..000000000000 --- a/libgfortran/caf/shmem/counter_barrier.c +++ /dev/null @@ -1,121 +0,0 @@ -/* 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 deleted file mode 100644 index a28c58812a54..000000000000 --- a/libgfortran/caf/shmem/counter_barrier.h +++ /dev/null @@ -1,76 +0,0 @@ -/* 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 deleted file mode 100644 index e17d6dd2dcab..000000000000 --- a/libgfortran/caf/shmem/hashmap.c +++ /dev/null @@ -1,366 +0,0 @@ -/* 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 deleted file mode 100644 index bc263d32dcd4..000000000000 --- a/libgfortran/caf/shmem/hashmap.h +++ /dev/null @@ -1,98 +0,0 @@ -/* 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 deleted file mode 100644 index 2b3666ddd3b9..000000000000 --- a/libgfortran/caf/shmem/shared_memory.c +++ /dev/null @@ -1,200 +0,0 @@ -/* 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 deleted file mode 100644 index 01ac2811e5d6..000000000000 --- a/libgfortran/caf/shmem/shared_memory.h +++ /dev/null @@ -1,93 +0,0 @@ -/* 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 deleted file mode 100644 index 9e5b794a23f0..000000000000 --- a/libgfortran/caf/shmem/supervisor.c +++ /dev/null @@ -1,311 +0,0 @@ -/* 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 deleted file mode 100644 index 7afb82696749..000000000000 --- a/libgfortran/caf/shmem/supervisor.h +++ /dev/null @@ -1,112 +0,0 @@ -/* 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 deleted file mode 100644 index a456244629ca..000000000000 --- a/libgfortran/caf/shmem/sync.c +++ /dev/null @@ -1,182 +0,0 @@ -/* 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 deleted file mode 100644 index a3e586bca244..000000000000 --- a/libgfortran/caf/shmem/sync.h +++ /dev/null @@ -1,79 +0,0 @@ -/* 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 deleted file mode 100644 index 44a34d727c36..000000000000 --- a/libgfortran/caf/shmem/teams_mgmt.c +++ /dev/null @@ -1,83 +0,0 @@ -/* 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 deleted file mode 100644 index f96f4aea33e6..000000000000 --- a/libgfortran/caf/shmem/teams_mgmt.h +++ /dev/null @@ -1,93 +0,0 @@ -/* 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 deleted file mode 100644 index 572f39400b38..000000000000 --- a/libgfortran/caf/shmem/thread_support.c +++ /dev/null @@ -1,73 +0,0 @@ -/* 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 deleted file mode 100644 index e70b4b83c7d6..000000000000 --- a/libgfortran/caf/shmem/thread_support.h +++ /dev/null @@ -1,38 +0,0 @@ -/* 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 a6576f28260c..97876fa9d8c2 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 = vsnprintf (errmsg, errmsg_len, msg, args); + int len = snprintf (errmsg, errmsg_len, msg, args); if (len >= 0 && errmsg_len > (size_t) len) memset (&errmsg[len], ' ', errmsg_len - len); } From 325fe226201076eed436254e0e8eec8718f589da Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Thu, 2 Oct 2025 17:10:07 -0700 Subject: [PATCH 7/7] Fortran: Andre's coarray patch series, ver 4 gcc/fortran/ChangeLog: * check.cc (gfc_check_image_status): mod (gfc_check_failed_or_stopped_images): mod * invoke.texi: mod * trans-expr.cc (get_scalar_to_descriptor_type): mod (copy_coarray_desc_part): mod (gfc_class_array_data_assign): mod (gfc_conv_derived_to_class): mod * trans-intrinsic.cc (conv_intrinsic_image_status): mod * trans-stmt.cc (gfc_trans_sync): mod libgfortran/ChangeLog: * Makefile.am: mod * Makefile.in: mod * acinclude.m4: mod * caf/libcaf.h (LIBCAF_H): mod (_gfortran_caf_failed_images): mod (_gfortran_caf_image_status): mod (_gfortran_caf_stopped_images): mod * caf/single.c (caf_internal_error): mod * config.h.in: Regenerate. * configure: Regenerate. * configure.ac: mod * caf/caf_error.c: New file. * caf/caf_error.h: New file. * caf/shmem.c: New file. * caf/shmem/alloc.c: New file. * caf/shmem/alloc.h: New file. * caf/shmem/allocator.c: New file. * caf/shmem/allocator.h: New file. * caf/shmem/collective_subroutine.c: New file. * caf/shmem/collective_subroutine.h: New file. * caf/shmem/counter_barrier.c: New file. * caf/shmem/counter_barrier.h: New file. * caf/shmem/hashmap.c: New file. * caf/shmem/hashmap.h: New file. * caf/shmem/shared_memory.c: New file. * caf/shmem/shared_memory.h: New file. * caf/shmem/supervisor.c: New file. * caf/shmem/supervisor.h: New file. * caf/shmem/sync.c: New file. * caf/shmem/sync.h: New file. * caf/shmem/teams_mgmt.c: New file. * caf/shmem/teams_mgmt.h: New file. * caf/shmem/thread_support.c: New file. * caf/shmem/thread_support.h: New file. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/alloc_comp_4.f90: mod * gfortran.dg/coarray/atomic_2.f90: mod * gfortran.dg/coarray/caf.exp: mod * gfortran.dg/coarray/coarray_allocated.f90: mod * gfortran.dg/coarray/coindexed_1.f90: mod * gfortran.dg/coarray/coindexed_3.f08: mod * gfortran.dg/coarray/coindexed_5.f90: mod * gfortran.dg/coarray/dummy_3.f90: mod * gfortran.dg/coarray/event_1.f90: mod * gfortran.dg/coarray/event_3.f08: mod * gfortran.dg/coarray/event_4.f08: mod * gfortran.dg/coarray/failed_images_1.f08: mod * gfortran.dg/coarray/failed_images_2.f08: mod * gfortran.dg/coarray/image_status_1.f08: mod * gfortran.dg/coarray/image_status_2.f08: mod * gfortran.dg/coarray/lock_2.f90: mod * gfortran.dg/coarray/poly_run_3.f90: mod * gfortran.dg/coarray/scalar_alloc_1.f90: mod * gfortran.dg/coarray/stopped_images_1.f08: mod * gfortran.dg/coarray/stopped_images_2.f08: mod * gfortran.dg/coarray/sync_1.f90: mod * gfortran.dg/coarray/sync_3.f90: mod * gfortran.dg/coarray_sync_memory.f90: mod * gfortran.dg/coarray/co_reduce_string.f90: New test. * gfortran.dg/coarray/sync_team.f90: New test. --- gcc/fortran/check.cc | 11 +- gcc/fortran/invoke.texi | 63 + gcc/fortran/trans-expr.cc | 68 +- gcc/fortran/trans-intrinsic.cc | 6 +- gcc/fortran/trans-stmt.cc | 7 +- .../gfortran.dg/coarray/alloc_comp_4.f90 | 16 +- .../gfortran.dg/coarray/atomic_2.f90 | 25 +- gcc/testsuite/gfortran.dg/coarray/caf.exp | 13 + .../gfortran.dg/coarray/co_reduce_string.f90 | 94 + .../gfortran.dg/coarray/coarray_allocated.f90 | 9 +- .../gfortran.dg/coarray/coindexed_1.f90 | 74 +- .../gfortran.dg/coarray/coindexed_3.f08 | 4 +- .../gfortran.dg/coarray/coindexed_5.f90 | 108 +- gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 | 1 + gcc/testsuite/gfortran.dg/coarray/event_1.f90 | 75 +- gcc/testsuite/gfortran.dg/coarray/event_3.f08 | 4 +- gcc/testsuite/gfortran.dg/coarray/event_4.f08 | 3 +- .../gfortran.dg/coarray/failed_images_1.f08 | 2 +- .../gfortran.dg/coarray/failed_images_2.f08 | 39 +- .../gfortran.dg/coarray/image_status_1.f08 | 2 +- .../gfortran.dg/coarray/image_status_2.f08 | 32 +- gcc/testsuite/gfortran.dg/coarray/lock_2.f90 | 2 + .../gfortran.dg/coarray/poly_run_3.f90 | 8 +- .../gfortran.dg/coarray/scalar_alloc_1.f90 | 13 +- .../gfortran.dg/coarray/stopped_images_1.f08 | 2 +- .../gfortran.dg/coarray/stopped_images_2.f08 | 39 +- gcc/testsuite/gfortran.dg/coarray/sync_1.f90 | 8 +- gcc/testsuite/gfortran.dg/coarray/sync_3.f90 | 26 +- .../gfortran.dg/coarray/sync_team.f90 | 33 + .../gfortran.dg/coarray_sync_memory.f90 | 4 +- libgfortran/Makefile.am | 23 +- libgfortran/Makefile.in | 133 +- libgfortran/acinclude.m4 | 12 + libgfortran/caf/caf_error.c | 71 + libgfortran/caf/caf_error.h | 44 + libgfortran/caf/libcaf.h | 12 +- libgfortran/caf/shmem.c | 1906 +++++++++++++++++ libgfortran/caf/shmem/alloc.c | 168 ++ libgfortran/caf/shmem/alloc.h | 80 + libgfortran/caf/shmem/allocator.c | 145 ++ libgfortran/caf/shmem/allocator.h | 88 + libgfortran/caf/shmem/collective_subroutine.c | 434 ++++ libgfortran/caf/shmem/collective_subroutine.h | 50 + libgfortran/caf/shmem/counter_barrier.c | 127 ++ libgfortran/caf/shmem/counter_barrier.h | 80 + libgfortran/caf/shmem/hashmap.c | 366 ++++ libgfortran/caf/shmem/hashmap.h | 98 + libgfortran/caf/shmem/shared_memory.c | 292 +++ libgfortran/caf/shmem/shared_memory.h | 96 + libgfortran/caf/shmem/supervisor.c | 550 +++++ libgfortran/caf/shmem/supervisor.h | 119 + libgfortran/caf/shmem/sync.c | 182 ++ libgfortran/caf/shmem/sync.h | 77 + libgfortran/caf/shmem/teams_mgmt.c | 83 + libgfortran/caf/shmem/teams_mgmt.h | 93 + libgfortran/caf/shmem/thread_support.c | 381 ++++ libgfortran/caf/shmem/thread_support.h | 113 + libgfortran/caf/single.c | 2 +- libgfortran/config.h.in | 12 + libgfortran/configure | 74 +- libgfortran/configure.ac | 7 +- 61 files changed, 6493 insertions(+), 216 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 create mode 100644 gcc/testsuite/gfortran.dg/coarray/sync_team.f90 create mode 100644 libgfortran/caf/caf_error.c create mode 100644 libgfortran/caf/caf_error.h create mode 100644 libgfortran/caf/shmem.c create mode 100644 libgfortran/caf/shmem/alloc.c create mode 100644 libgfortran/caf/shmem/alloc.h create mode 100644 libgfortran/caf/shmem/allocator.c create mode 100644 libgfortran/caf/shmem/allocator.h create mode 100644 libgfortran/caf/shmem/collective_subroutine.c create mode 100644 libgfortran/caf/shmem/collective_subroutine.h create mode 100644 libgfortran/caf/shmem/counter_barrier.c create mode 100644 libgfortran/caf/shmem/counter_barrier.h create mode 100644 libgfortran/caf/shmem/hashmap.c create mode 100644 libgfortran/caf/shmem/hashmap.h create mode 100644 libgfortran/caf/shmem/shared_memory.c create mode 100644 libgfortran/caf/shmem/shared_memory.h create mode 100644 libgfortran/caf/shmem/supervisor.c create mode 100644 libgfortran/caf/shmem/supervisor.h create mode 100644 libgfortran/caf/shmem/sync.c create mode 100644 libgfortran/caf/shmem/sync.h create mode 100644 libgfortran/caf/shmem/teams_mgmt.c create mode 100644 libgfortran/caf/shmem/teams_mgmt.h create mode 100755 libgfortran/caf/shmem/thread_support.c create mode 100755 libgfortran/caf/shmem/thread_support.h diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 1f170131ae14..fae628bae409 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1865,7 +1865,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team) || !positive_check (0, image)) return false; - return !team || (scalar_check (team, 0) && team_type_check (team, 0)); + return !team || (scalar_check (team, 1) && team_type_check (team, 1)); } @@ -1908,13 +1908,8 @@ gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis) bool gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind) { - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &team->where); - return false; - } + if (team && (!scalar_check (team, 0) || !team_type_check (team, 0))) + return false; if (kind) { diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index a65f2d1cc34f..d0c03f0f583a 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 @@ -2294,3 +2295,65 @@ variables. @xref{Runtime}, for environment variables that affect the run-time behavior of programs compiled with GNU Fortran. @c man end + +@node Shared Memory Coarrays +@section Shared Memory Coarrays + +@c man begin SHARED MEMORY COARRAYS + +@command{gfortran} supplies a runtime library for running coarray enabled +programs using a shared memory multi process approach. The library is supplied +as a static link library with the @command{libgfortran} library and is fully +compatible with the ABI enabled when @command{gfortran} is called with +@code{-fcoarray=lib}. The shared memory coarray library then just needs to be +linked to the executable produced by @command{gfortran} using +@code{-lcaf_shmem}. + +The library @code{caf_shmem} can only be used on architectures that allow +multiple processes to use the same memory at the same virtual memory address in +each process' memory space. This is the case on most Unix and Windows based +systems. + +The resulting executable can be started without any driver and does not provide +any additional command line options. Limited control is possible by +environment variables: + +@env{GFORTRAN_NUM_IMAGES}: The number of images to spawn when running the +executable. Note, there will always be one additional supervisor process, which +does not participate in the computation, but is only responsible for starting +the images and catching any (ab-)normal termination. When the environment +variable is not set, then the number of hardware threads reported by the OS will +be taken. Over-provisioning is possible. The number of images is limited only +by the OS and the size of an integer variable on the architecture the program is +to be run on. + +@env{GFORTRAN_SHARED_MEMORY_SIZE}: The size of the shared memory segment made +available to all images is fixed and needs to be set at program start. It can +not grow or shrink. The size can be given in bytes (no suffix), kilobytes +(@code{k} or @code{K} suffix), megabytes (@code{m} or @code{M}) or gigabytes +(@code{g} or @code{G}). If the variable is not set, or not parseable, then on +32-bit architectures 2^28 bytes and on 64-bit 2^34 bytes are choosen. Note, +although the size is set, most modern systems do not allocate the memory at +program start. This allows to choose a shared memory size larger than available +memory. + +Warning: Choosing a large shared memory size may produce large coredumps! + +@env{GFORTRAN_IMAGE_RESTARTS_LIMIT}: On certain platforms, esp. MacOS, the +shared memory segment needs to be placed on the same (virtual) address in every +image or synchronisation primitives do not work as expected. Unfortunately are +some OSes somewhat arbitrary on when they can do this. When the OS is not able +to fullfill the request, then the image aborts itsself and is restarted by the +supervisor untill the OS complies. This environment variable limits the total +number of restarts of all images having an issue with shared memory segment +placement. The default value is 4000. + +The shared memory coarray library internally uses some additional environment +variables, which will be overwritten without notice or may result in failure to +start. These are: @code{GFORTRAN_IMAGE_NUM}, @code{GFORTRAN_SHMEM_PID} and +@code{GFORTRAN_SHMEM_BASE}. It is strongly discouraged to use these variables. +Special care needs to be taken, when one coarray program starts another coarray +program as a child process. In this case it is the spawning process' +responsibility to remove above variables from the environment. + +@c man end diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 271d2633dfba..80b0842f35a3 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 (tmp) : TREE_TYPE (tmp2); - tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, - gfc_index_zero_node, NULL_TREE, NULL_TREE); - gfc_add_modify (block, tmp, tmp2); + type = lhs_type ? TREE_TYPE (lhs_dim) : TREE_TYPE (rhs_dim); + lhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, lhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + rhs_dim = build4_loc (input_location, ARRAY_RANGE_REF, type, rhs_dim, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, lhs_dim, rhs_dim); + + /* The corank dimensions are not copied by the ARRAY_RANGE_REF. */ + copy_coarray_desc_part (block, lhs_desc, rhs_desc); } /* Takes a derived type expression and returns the address of a temporary @@ -920,6 +965,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym, gfc_expr_attr (e)); gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree), gfc_get_dtype (type)); + copy_coarray_desc_part (&parmse->pre, ctree, parmse->expr); if (optional) parmse->expr = build3_loc (input_location, COND_EXPR, TREE_TYPE (parmse->expr), diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index d1c2a80b2775..46d90466f373 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 f25335d6bdbd..4bfab4f20f8d 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 2ee8ff0253d6..50b4bab1603a 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 5e1c4967248c..7eccd7b578ca 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 c1e8e8ca2b0b..1f002e08fa3f 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 000000000000..9b4c44f1ada6 --- /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 27db0e8d8ce0..ce7c6288a611 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 f90b65cb3898..8f7a83a9c996 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 7fd20851e0a9..145835d461b3 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 c35ec1093c1f..8eb646696280 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 4b45daab6493..c569390e7c62 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 81dc90b7197b..a9fecf939843 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 +associate (me => this_image(), np => num_images()) + allocate(events(np)[*]) -stat = 99 -event post (var, stat=stat) -if (stat /= 0) STOP 2 -call event_query(var, count, stat=stat) -if (count /= 1 .or. stat /= 0) STOP 3 + associate(var => events(me)) + count = -42 + call event_query (var, count) + if (count /= 0) STOP 1 -stat = 99 -event post (var[this_image()]) -call event_query(var, count) -if (count /= 2) STOP 4 + stat = 99 + event post (var, stat=stat) + if (stat /= 0) STOP 2 + call event_query(var, count, stat=stat) + if (count /= 1 .or. stat /= 0) STOP 3 -stat = 99 -event wait (var) -call event_query(var, count) -if (count /= 1) STOP 5 + count = 99 + event post (var[this_image()]) + call event_query(var, count) + if (count /= 2) STOP 4 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 2) STOP 6 + count = 99 + event wait (var) + call event_query(var, count) + if (count /= 1) STOP 5 -stat = 99 -event post (var) -call event_query(var, count) -if (count /= 3) STOP 7 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 2) STOP 6 -stat = 99 -event wait (var, until_count=2) -call event_query(var, count) -if (count /= 1) STOP 8 + count = 99 + event post (var) + call event_query(var, count) + if (count /= 3) STOP 7 -stat = 99 -event wait (var, stat=stat, until_count=1) -if (stat /= 0) STOP 9 -call event_query(event=var, stat=stat, count=count) -if (count /= 0 .or. stat /= 0) STOP 10 + count = 99 + event wait (var, until_count=2) + call event_query(var, count) + if (count /= 1) STOP 8 + + stat = 99 + event wait (var, stat=stat, until_count=1) + if (stat /= 0) STOP 9 + count = 99 + call event_query(event=var, stat=stat, count=count) + if (count /= 0 .or. stat /= 0) STOP 10 + end associate +end associate end diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index 60d3193f776d..cedf636b79b3 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 de901c01aa43..26a1f59df030 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 4898dd8a7a2f..34ae131d15f1 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 ca5fe4020d5e..78d92daf0715 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 b7ec5a6a9c97..f725f81d4aad 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 fb49289cb782..8866f2374819 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 8e96154996d4..3d445b9b5e82 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 c284a5667607..4da1b9569fe6 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 b0d27bdfb8fa..8dd7df5d4362 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 403de585b9af..7658e6bb6bbb 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 0bf4a81a7e20..dadd00ecda7a 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 8633c4aa527d..4abe5a3b5487 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 fe1e4c548c85..ceb4b19d5171 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 000000000000..a96884549a3d --- /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 c4e660b8cf72..0030d91257d5 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 4f3b30332245..f912824d208b 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 dd88f8893b7f..217a44e81f23 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,6 +1991,37 @@ caf/$(am__dirstamp): caf/$(DEPDIR)/$(am__dirstamp): @$(MKDIR_P) caf/$(DEPDIR) @: > caf/$(DEPDIR)/$(am__dirstamp) +caf/caf_error.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp) +caf/shmem.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp) +caf/shmem/$(am__dirstamp): + @$(MKDIR_P) caf/shmem + @: > caf/shmem/$(am__dirstamp) +caf/shmem/$(DEPDIR)/$(am__dirstamp): + @$(MKDIR_P) caf/shmem/$(DEPDIR) + @: > caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/alloc.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/allocator.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/collective_subroutine.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/counter_barrier.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/hashmap.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/shared_memory.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/supervisor.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/sync.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/teams_mgmt.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) +caf/shmem/thread_support.lo: caf/shmem/$(am__dirstamp) \ + caf/shmem/$(DEPDIR)/$(am__dirstamp) + +libcaf_shmem.la: $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_DEPENDENCIES) $(EXTRA_libcaf_shmem_la_DEPENDENCIES) + $(AM_V_GEN)$(libcaf_shmem_la_LINK) -rpath $(cafexeclibdir) $(libcaf_shmem_la_OBJECTS) $(libcaf_shmem_la_LIBADD) $(LIBS) caf/single.lo: caf/$(am__dirstamp) caf/$(DEPDIR)/$(am__dirstamp) libcaf_single.la: $(libcaf_single_la_OBJECTS) $(libcaf_single_la_DEPENDENCIES) $(EXTRA_libcaf_single_la_DEPENDENCIES) @@ -3771,6 +3829,8 @@ mostlyclean-compile: -rm -f *.$(OBJEXT) -rm -f caf/*.$(OBJEXT) -rm -f caf/*.lo + -rm -f caf/shmem/*.$(OBJEXT) + -rm -f caf/shmem/*.lo -rm -f generated/*.$(OBJEXT) -rm -f generated/*.lo -rm -f ieee/*.$(OBJEXT) @@ -3785,7 +3845,19 @@ mostlyclean-compile: distclean-compile: -rm -f *.tab.c +@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/caf_error.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/shmem.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@caf/$(DEPDIR)/single.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/alloc.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/allocator.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/collective_subroutine.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/counter_barrier.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/hashmap.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/shared_memory.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/supervisor.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/sync.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/teams_mgmt.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@caf/shmem/$(DEPDIR)/thread_support.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/all_l2.Plo@am__quote@ @@ -4550,6 +4622,7 @@ mostlyclean-libtool: clean-libtool: -rm -rf .libs _libs -rm -rf caf/.libs caf/_libs + -rm -rf caf/shmem/.libs caf/shmem/_libs -rm -rf generated/.libs generated/_libs -rm -rf ieee/.libs ieee/_libs -rm -rf intrinsics/.libs intrinsics/_libs @@ -4717,6 +4790,8 @@ distclean-generic: -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) -rm -f caf/$(DEPDIR)/$(am__dirstamp) -rm -f caf/$(am__dirstamp) + -rm -f caf/shmem/$(DEPDIR)/$(am__dirstamp) + -rm -f caf/shmem/$(am__dirstamp) -rm -f generated/$(DEPDIR)/$(am__dirstamp) -rm -f generated/$(am__dirstamp) -rm -f ieee/$(DEPDIR)/$(am__dirstamp) @@ -4739,7 +4814,7 @@ clean-am: clean-cafexeclibLTLIBRARIES clean-generic clean-libtool \ distclean: distclean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) - -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-hdr distclean-libtool distclean-local distclean-tags @@ -4788,7 +4863,7 @@ installcheck-am: maintainer-clean: maintainer-clean-am -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache - -rm -rf caf/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) + -rm -rf caf/$(DEPDIR) caf/shmem/$(DEPDIR) generated/$(DEPDIR) ieee/$(DEPDIR) intrinsics/$(DEPDIR) io/$(DEPDIR) runtime/$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic \ maintainer-clean-local diff --git a/libgfortran/acinclude.m4 b/libgfortran/acinclude.m4 index 23fd621e5188..13097b4ab926 100644 --- a/libgfortran/acinclude.m4 +++ b/libgfortran/acinclude.m4 @@ -578,3 +578,15 @@ main () [Define to 1 if you have the `$1' function.]) fi ]) + +AC_DEFUN([LIBGFOR_CHECK_SANE_BUILTIN_CLZL], [ + AC_RUN_IFELSE([AC_LANG_PROGRAM([[ + int main() + { + return __builtin_clzl(256) != 8; + }]], [[]])], + AC_DEFINE(HAVE_SANE_BUILTIN_CLZL, 1, + [Define if __builtin_clzl behaves as expected.]) + AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],true), + [AM_CONDITIONAL([HAVE_SANE_BUILTIN_CLZL],false)]) +]) diff --git a/libgfortran/caf/caf_error.c b/libgfortran/caf/caf_error.c new file mode 100644 index 000000000000..a8f3bf7f189b --- /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 000000000000..15455377eb03 --- /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 7267bc76905e..80ea72ff7426 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 000000000000..446e5f54483c --- /dev/null +++ b/libgfortran/caf/shmem.c @@ -0,0 +1,1906 @@ +/* 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; + + thread_support_cleanup (); + 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; + + shared_memory_cleanup (&local->sm); + free (local); + + thread_support_cleanup (); +} + +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; + size_t alloc_size; + + allocator_lock (&local->ai.alloc); +#if defined(WIN32) || defined(__CYGWIN__) + /* On Windows mutexes are not an object stored in the shmem but + identified by an id. */ + alloc_size = size * caf_current_team->u.image_info->image_count.count; +#else + alloc_size = size; +#endif + addr = alloc_get_memory_by_id_created (&local->ai, + alloc_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 < alloc_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"); \ + opr = NULL; /* Prevent false warnings. */ \ + } \ + 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"); \ + opr = NULL; /* Prevent false warning. */ \ + } \ + break; \ + default: \ + caf_runtime_error ("" #name " not available for type/kind combination"); \ + opr = NULL; /* Prevent false warning. */ \ + } + +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, + int *acquired_lock, int *stat, char *errmsg, + size_t errmsg_len) +{ + const char *msg = "Already locked"; +#if defined(WIN32) || defined(__CYGWIN__) + const size_t lock_index + = image_index * caf_current_team->u.image_info->image_count.count + index; +#else + const size_t lock_index = index; + (void) image_index; // Prevent unused warnings. +#endif + lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index]; + int res; + + res = acquired_lock ? caf_shmem_mutex_trylock (lock) + : caf_shmem_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, + int *stat, char *errmsg, size_t errmsg_len) +{ + const char *msg = "Variable is not locked"; +#if defined(WIN32) || defined(__CYGWIN__) + const size_t lock_index + = image_index * caf_current_team->u.image_info->image_count.count + index; +#else + const size_t lock_index = index; + (void) image_index; // Prevent unused warnings. +#endif + lock_t *lock = &((lock_t *) MEMTOK (token))[lock_index]; + int res; + + res = caf_shmem_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 = caf_shmem_mutex_trylock (lock); + if (res == EBUSY) + *stat = GFC_STAT_LOCKED_OTHER_IMAGE; + else + { + *stat = GFC_STAT_UNLOCKED; + caf_shmem_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_init_add (&t->u.image_info->image_count, 1); + counter_barrier_init_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 000000000000..ea250ac6922f --- /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 "thread_support.h" + +#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 000000000000..d85b1a30236c --- /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 000000000000..bd88f33e2000 --- /dev/null +++ b/libgfortran/caf/shmem/allocator.c @@ -0,0 +1,145 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +/* Main allocation routine, works like malloc. Round up allocations + to the next power of two and keep free lists in buckets. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include "libgfortran.h" + +#include "allocator.h" +#include "supervisor.h" +#include "thread_support.h" + +#include + +typedef struct +{ + shared_mem_ptr next; +} bucket; + +size_t +alignto (size_t size, size_t align) +{ + return align * ((size + align - 1) / align); +} + +size_t pagesize; + +size_t +round_to_pagesize (size_t s) +{ + return alignto (s, pagesize); +} + +/* Initialize the allocator. */ + +void +allocator_init (allocator *a, allocator_shared *s, shared_memory sm) +{ + *a = (allocator) {s, sm}; +} + +void +allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm) +{ + *a = (allocator) {s, sm}; + initialize_shared_mutex (&s->lock); + for (size_t i = 0; i < VOIDP_BITS; i++) + s->free_bucket_head[i] = SHMPTR_NULL; +} + +#define MAX_ALIGN 16 + +static size_t +next_power_of_two (size_t size) +{ +#ifdef HAVE_SANE_BUILTIN_CLZL + assert (size); +#if (__INTPTR_WIDTH__ == 64) + return 1 << (VOIDP_BITS - __builtin_clzl (size - 1)); +#else + return 1 << (VOIDP_BITS - __builtin_clz (size - 1)); +#endif +#else + return 1 << (int)ceil(log2(size)); +#endif +} + +shared_mem_ptr +allocator_shared_malloc (allocator *a, size_t size) +{ + shared_mem_ptr ret; + size_t sz; + size_t act_size; + int bucket_list_index; + + sz = next_power_of_two (size); + act_size = sz > sizeof (bucket) ? sz : sizeof (bucket); + bucket_list_index = __builtin_clzl (act_size); + assert (bucket_list_index + < (int) (sizeof (a->s->free_bucket_head) / sizeof (shared_mem_ptr))); + + if (SHMPTR_IS_NULL (a->s->free_bucket_head[bucket_list_index])) + return shared_memory_get_mem_with_alignment (a->shm, act_size, MAX_ALIGN); + + ret = a->s->free_bucket_head[bucket_list_index]; + a->s->free_bucket_head[bucket_list_index] + = (SHMPTR_AS (bucket *, ret, a->shm)->next); + return ret; +} + +/* Free memory. */ + +void +allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size) +{ + bucket *b; + size_t sz; + int bucket_list_index; + size_t act_size; + + sz = next_power_of_two (size); + act_size = sz > sizeof (bucket) ? sz : sizeof (bucket); + bucket_list_index = __builtin_clzl (act_size); + + b = SHMPTR_AS (bucket *, p, a->shm); + b->next = a->s->free_bucket_head[bucket_list_index]; + a->s->free_bucket_head[bucket_list_index] = p; +} + +void +allocator_lock (allocator *a) +{ + caf_shmem_mutex_lock (&a->s->lock); +} + +void +allocator_unlock (allocator *a) +{ + caf_shmem_mutex_unlock (&a->s->lock); +} diff --git a/libgfortran/caf/shmem/allocator.h b/libgfortran/caf/shmem/allocator.h new file mode 100644 index 000000000000..0cf31ea837a7 --- /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 "thread_support.h" + +#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 { + caf_shmem_mutex lock; + shared_mem_ptr free_bucket_head[VOIDP_BITS]; +} allocator_shared; + +/* The image local part of the allocator. */ +typedef struct { + allocator_shared *s; + shared_memory shm; +} allocator; + +/* The size of a page on this architecture. */ +extern size_t pagesize; + +/* Helper routine to align a size to a given boundary. */ +size_t alignto (size_t, size_t); + +/* Helper routine to round a size to multiple of the architecture's pagesize. + */ +size_t round_to_pagesize (size_t); + +/* Link the worker's allocator with the part in the shared memory. */ +void allocator_init (allocator *, allocator_shared *, shared_memory); + +/* Initialize the allocator. This MUST be called ONLY be the supervisor and + only once! */ +void allocator_init_supervisor (allocator *, allocator_shared *, shared_memory); + +/* Request a block of shared memory. The memory is not linked with the other + images. The shared_mem_ptr returned is only local to the calling image. + When requiring a memory block shared between all images, call + alloc_get_memory_by_id...(). */ +shared_mem_ptr allocator_shared_malloc (allocator *, size_t size); + +/* Free the given piece of memory. This routine just inserts the memory chunk + into the bucket list of free memory. It does not join adjacent blocks of + memory (not implemented yet). */ +void allocator_shared_free (allocator *, shared_mem_ptr, size_t size); + +/* Lock the allocator lock preventing any image from modifying memory management + structures. Do not forget to unlock. This interface is exposed to be able + to do more then just get the memory without having to introduce a second lock + and the problems with having to get both. */ +void allocator_lock (allocator *); + +/* Unlock the allocator lock. */ +void allocator_unlock (allocator *); + +#endif diff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c new file mode 100644 index 000000000000..d261b412a932 --- /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; + + caf_shmem_mutex_lock (&caf_current_team->u.image_info->collsub.mutex); + /* curr_size is always at least sizeof(double), so we don't need to worry + about size == 0. */ + if (size > caf_current_team->u.image_info->collsub.curr_size) + { + allocator_shared_free ( + alloc_get_allocator (&local->ai), + caf_current_team->u.image_info->collsub.collsub_buf, + caf_current_team->u.image_info->collsub.curr_size); + caf_current_team->u.image_info->collsub.collsub_buf + = allocator_shared_malloc (alloc_get_allocator (&local->ai), size); + caf_current_team->u.image_info->collsub.curr_size = size; + } + + ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf, + &local->sm); + caf_shmem_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex); + return ret; +} + +/* This function syncs all images with one another. It will only return once + all images have called it. */ + +static void +collsub_sync (void) +{ + counter_barrier_wait (&caf_current_team->u.image_info->collsub.barrier); +} + +typedef void *(*red_op) (void *, void *); +typedef void (*ass_op) (red_op, void *, void *, size_t); + +#define GEN_FOR_BITS(BITS) \ + static void assign_##BITS (void *op, uint##BITS##_t *lhs, \ + uint##BITS##_t *rhs, size_t) \ + { \ + *lhs \ + = ((uint##BITS##_t (*) (uint##BITS##_t *, uint##BITS##_t *)) op) (lhs, \ + rhs); \ + } \ + static void assign_by_val_##BITS (void *op, uint##BITS##_t *lhs, \ + uint##BITS##_t *rhs, size_t) \ + { \ + *lhs = ((uint##BITS##_t (*) (uint##BITS##_t, uint##BITS##_t)) op) (*lhs, \ + *rhs); \ + } + +GEN_FOR_BITS (8) +GEN_FOR_BITS (16) +GEN_FOR_BITS (32) +GEN_FOR_BITS (64) +// GEN_FOR_BITS (128) + +static void +assign_float (void *op, float *lhs, float *rhs, size_t) +{ + *lhs = ((float (*) (float *, float *)) op) (lhs, rhs); +} + +static void +assign_double (void *op, double *lhs, double *rhs, size_t) +{ + *lhs = ((double (*) (double *, double *)) op) (lhs, rhs); +} + +static void +assign_var (red_op op, void *lhs, void *rhs, size_t sz) +{ + memcpy (lhs, op (lhs, rhs), sz); +} + +static void +assign_char (void *op, void *lhs, void *rhs, size_t sz) +{ + ((void (*) (char *, size_t, char *, char *, size_t, + size_t)) op) (lhs, sz, lhs, rhs, sz, sz); +} + +static ass_op +gen_reduction (const int type, const size_t sz, const int flags) +{ + const bool by_val = flags & GFC_CAF_ARG_VALUE; + switch (type) + { + case BT_CHARACTER: + return (ass_op) assign_char; + case BT_REAL: + switch (sz) + { + case 4: + return (ass_op) assign_float; + case 8: + return (ass_op) assign_double; + default: + return assign_var; + } + default: + switch (sz) + { + case 1: + return (ass_op) (by_val ? assign_by_val_8 : assign_8); + case 2: + return (ass_op) (by_val ? assign_by_val_16 : assign_16); + case 4: + return (ass_op) (by_val ? assign_by_val_32 : assign_32); + case 8: + return (ass_op) (by_val ? assign_by_val_64 : assign_64); + // case 16: + // return assign_128; + default: + return assign_var; + } + } +} + +/* Having result_image == -1 means allreduce. */ + +void +collsub_reduce_array (gfc_descriptor_t *desc, int result_image, + void *(*op) (void *, void *), int opr_flags, + int str_len __attribute__ ((unused))) +{ + void *buffer; + pack_info pi; + bool packed; + int cbit = 0; + int imoffset; + index_type elem_size; + index_type this_image_size_bytes; + void *this_image_buf, *roll_iter, *src_iter; + ass_op assign; + const int this_img_id = caf_current_team->index; + + packed = pack_array_prepare (&pi, desc); + if (pi.num_elem == 0) + return; + + elem_size = GFC_DESCRIPTOR_SPAN (desc); + this_image_size_bytes = elem_size * pi.num_elem; + + buffer = get_collsub_buf ( + this_image_size_bytes * caf_current_team->u.image_info->image_count.count); + this_image_buf = buffer + this_image_size_bytes * this_img_id; + + if (packed) + memcpy (this_image_buf, GFC_DESCRIPTOR_DATA (desc), this_image_size_bytes); + else + pack_array_finish (&pi, desc, this_image_buf); + + assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags); + collsub_sync (); + + for (; ((this_img_id >> cbit) & 1) == 0 + && (caf_current_team->u.image_info->image_count.count >> cbit) != 0; + cbit++) + { + imoffset = 1 << cbit; + if (this_img_id + imoffset + < caf_current_team->u.image_info->image_count.count) + { + /* Reduce arrays elementwise. */ + roll_iter = this_image_buf; + src_iter = this_image_buf + this_image_size_bytes * imoffset; + for (ssize_t i = 0; i < pi.num_elem; + ++i, roll_iter += elem_size, src_iter += elem_size) + assign (op, roll_iter, src_iter, elem_size); + } + collsub_sync (); + } + for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0; + cbit++) + collsub_sync (); + + if (result_image < 0 || result_image == this_image.image_num) + { + if (packed) + memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, this_image_size_bytes); + else + unpack_array_finish (&pi, desc, buffer); + } + + collsub_sync (); +} + +/* Do not use sync_all(), because the program should deadlock in the case that + * some images are on a sync_all barrier while others are in a collective + * subroutine. */ + +void +collsub_broadcast_array (gfc_descriptor_t *desc, int source_image) +{ + void *buffer; + pack_info pi; + bool packed; + index_type elem_size; + index_type size_bytes; + + packed = pack_array_prepare (&pi, desc); + if (pi.num_elem == 0) + return; + + if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER) + { + if (GFC_DESCRIPTOR_SIZE (desc)) + elem_size = GFC_DESCRIPTOR_SIZE (desc); + else + elem_size = strlen (desc->base_addr); + } + else + elem_size = GFC_DESCRIPTOR_SPAN (desc) != 0 + ? ((index_type) GFC_DESCRIPTOR_SPAN (desc)) + : ((index_type) GFC_DESCRIPTOR_SIZE (desc)); + size_bytes = elem_size * pi.num_elem; + buffer = get_collsub_buf (size_bytes); + + if (source_image == this_image.image_num) + { + if (packed) + memcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes); + else + pack_array_finish (&pi, desc, buffer); + collsub_sync (); + } + else + { + collsub_sync (); + if (packed) + memcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes); + else + unpack_array_finish (&pi, desc, buffer); + } + + collsub_sync (); +} diff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h new file mode 100644 index 000000000000..bdddab07a930 --- /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; + caf_shmem_mutex mutex; +} collsub_shared; + +void collsub_init_supervisor (collsub_shared *, allocator *, + const int init_num_images); + +void collsub_broadcast_array (gfc_descriptor_t *, int); + +void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *), + int opr_flags, int str_len); + +#endif diff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c new file mode 100644 index 000000000000..2cda2afb2ed7 --- /dev/null +++ b/libgfortran/caf/shmem/counter_barrier.c @@ -0,0 +1,127 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#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) +{ + caf_shmem_mutex_lock (&b->mutex); +} + +/* Unlock the associated counter of this barrier. */ + +static inline void +unlock_counter_barrier (counter_barrier *b) +{ + caf_shmem_mutex_unlock (&b->mutex); +} + +void +counter_barrier_init (counter_barrier *b, int val) +{ + *b = (counter_barrier) {CAF_SHMEM_MUTEX_INITIALIZER, + CAF_SHMEM_COND_INITIALIZER, val, 0, val}; + initialize_shared_condition (&b->cond, val); + initialize_shared_mutex (&b->mutex); +} + +void +counter_barrier_wait (counter_barrier *b) +{ + int wait_group_beginning; + + lock_counter_barrier (b); + wait_group_beginning = b->curr_wait_group; + + if ((--b->wait_count) <= 0) + caf_shmem_cond_broadcast (&b->cond); + else + { + while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning) + caf_shmem_cond_wait (&b->cond, &b->mutex); + } + + if (b->wait_count <= 0) + { + b->curr_wait_group = !wait_group_beginning; + b->wait_count = b->count; + } + + unlock_counter_barrier (b); +} + +static inline void +change_internal_barrier_count (counter_barrier *b, int val) +{ + b->wait_count += val; + if (b->wait_count <= 0) + caf_shmem_cond_broadcast (&b->cond); +} + +int +counter_barrier_add_locked (counter_barrier *c, int val) +{ + int ret; + ret = (c->count += val); + change_internal_barrier_count (c, val); + + return ret; +} + +int +counter_barrier_add (counter_barrier *c, int val) +{ + int ret; + caf_shmem_mutex_lock (&c->mutex); + ret = counter_barrier_add_locked (c, val); + + caf_shmem_mutex_unlock (&c->mutex); + return ret; +} + +void +counter_barrier_init_add (counter_barrier *b, int val) +{ + b->count += val; + b->wait_count += val; + caf_shmem_cond_update_count (&b->cond, val); +} + +int +counter_barrier_get_count (counter_barrier *c) +{ + int ret; + caf_shmem_mutex_lock (&c->mutex); + ret = c->count; + caf_shmem_mutex_unlock (&c->mutex); + return ret; +} diff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h new file mode 100644 index 000000000000..ab3d35ada74c --- /dev/null +++ b/libgfortran/caf/shmem/counter_barrier.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 COUNTER_BARRIER_HDR +#define COUNTER_BARRIER_HDR + +#include "thread_support.h" + +/* Usable as counter barrier and as waitable counter. + This "class" allows to sync all images acting as a barrier. For this the + counter_barrier is to be initialized by the number of images and then later + calls to counter_barrier_wait() will sync the given number of images. There + is no order in which the images will be woken up from their wait. + Furthermore may this "class" be used as a event queue counter. To use it in + that way the counter barrier is to be initialized with zero. Every "add" to + the queue then is to be made by incrementing the counter_barrier every take + by decrementing the queue. If the queue does not satiesfy the needed number + of entries they can be waited for. + */ + +typedef struct +{ + caf_shmem_mutex mutex; + caf_shmem_condvar cond; + volatile int wait_count; + volatile int curr_wait_group; + volatile int count; +} counter_barrier; + +/* Initialize the counter barrier. Only to be called once per counter barrier. + I.e. a counter barrier in shared memory must only be initialized by one + image. */ + +void counter_barrier_init (counter_barrier *, int); + +/* Add the given number to the counter barrier. This signals waiting images + when the count drops below 0. This routine is only to be called, when the + image has taken the counter barrier's lock by some other way. */ + +int counter_barrier_add_locked (counter_barrier *, int); + +/* Add the given number to the counter barrier. This signals waiting images + when the count drops below 0. */ + +int counter_barrier_add (counter_barrier *, int); + +/* Add the given number to the counter barrier. This version does not signal. + The mutex needs to be locked for this routine to be safe. */ +void counter_barrier_init_add (counter_barrier *, int); + +/* Get the count of the barrier. */ + +int counter_barrier_get_count (counter_barrier *); + +/* Wait for the count in the barrier drop to or below 0. */ + +void counter_barrier_wait (counter_barrier *); + +#endif diff --git a/libgfortran/caf/shmem/hashmap.c b/libgfortran/caf/shmem/hashmap.c new file mode 100644 index 000000000000..e17d6dd2dcab --- /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 000000000000..bc263d32dcd4 --- /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 000000000000..0659e6ba0234 --- /dev/null +++ b/libgfortran/caf/shmem/shared_memory.c @@ -0,0 +1,292 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include "libgfortran.h" +#include "allocator.h" +#include "shared_memory.h" +#include "supervisor.h" + +#include +#include +#include +#include +#ifdef HAVE_SYS_MMAN_H +#include +#elif defined(WIN32) +#include +#include +#endif +#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); +#ifdef HAVE_SETENV + setenv (ENV_PPID, buffer, 1); +#else + SetEnvironmentVariable (ENV_PPID, buffer); +#endif +#undef bufsize +} + +char * +shared_memory_get_env (void) +{ + return getenv (ENV_PPID); +} + +/* Get a pointer into the shared memory block with alignemnt + (works similar to sbrk). */ + +shared_mem_ptr +shared_memory_get_mem_with_alignment (shared_memory_act *mem, size_t size, + size_t align) +{ + size_t aligned_curr_size = alignto (mem->glbl.meta->used, align); + mem->glbl.meta->used = aligned_curr_size + size; + return (shared_mem_ptr) {aligned_curr_size}; +} + +shared_mem_ptr +shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align) +{ + if (mem->glbl.meta->master) + return (shared_mem_ptr) {mem->glbl.meta->master}; + else + { + ptrdiff_t loc = mem->glbl.meta->used; + shared_mem_ptr p + = shared_memory_get_mem_with_alignment (mem, size, align); + mem->glbl.meta->master = loc; + return p; + } +} + +/* If another image changed the size, update the size accordingly. */ + +void +shared_memory_prepare (shared_memory_act *) +{ + asm volatile ("" ::: "memory"); +} + +#define NAME_MAX 255 + +/* Initialize the memory with one page, the shared metadata of the + shared memory is stored at the beginning. */ + +void +shared_memory_init (shared_memory_act *mem, size_t size) +{ + char shm_name[NAME_MAX]; + const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE); + pid_t ppid = getpid (); + void *base_ptr; + + if (env_val) + { + int n = sscanf (env_val, "%d", &ppid); + assert (n == 1); + } + snprintf (shm_name, NAME_MAX, "/gfor-shm-%d", ppid); + if (base) + { + int n = sscanf (base, "%p", &base_ptr); + assert (n == 1); + } + else + base_ptr = NULL; + + if (!env_val) + { +#ifdef HAVE_MMAP + int res; + + mem->shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600); + if (mem->shm_fd == -1) + { + perror ("creating shared memory segment failed."); + exit (1); + } + + res = ftruncate (mem->shm_fd, size); + if (res == -1) + { + perror ("resizing shared memory segment failed."); + exit (1); + } +#elif defined(WIN32) + mem->shm_fd + = CreateFileMapping (INVALID_HANDLE_VALUE, NULL, PAGE_READWRITE, + size >> (sizeof (DWORD) * 8), + (DWORD) (size & ~((DWORD) 0)), shm_name); + if (mem->shm_fd == NULL) + { + LPVOID lpMsgBuf; + DWORD dw = GetLastError (); + + if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER + | FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, dw, + MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &lpMsgBuf, 0, NULL) + == 0) + { + fprintf (stderr, "formatting the error message failed.\n"); + ExitProcess (dw); + } + + fprintf (stderr, "creating shared memory segment failed: %d, %s\n", + dw, (LPCTSTR) lpMsgBuf); + + LocalFree (lpMsgBuf); + exit (1); + } +#else +#error "no way to map shared memory." +#endif + } + else + { +#ifdef HAVE_MMAP + mem->shm_fd = shm_open (shm_name, O_RDWR, 0600); + if (mem->shm_fd == -1) + { + perror ("opening shared memory segment failed."); + exit (1); + } +#elif defined(WIN32) + mem->shm_fd = OpenFileMapping (FILE_MAP_ALL_ACCESS, FALSE, shm_name); + if (mem->shm_fd == NULL) + { + perror ("opening shared memory segment failed."); + exit (1); + } +#endif + } +#ifdef HAVE_MMAP + mem->glbl.base + = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, mem->shm_fd, 0); + if (base_ptr && mem->glbl.base != base_ptr) + { + /* The supervisor will start us again. */ + close (mem->shm_fd); + free (local); + exit (210); + } + else if (!base_ptr && !mem->glbl.base) + { + perror ("mmap failed"); + exit (1); + } +#elif defined(WIN32) + mem->glbl.base + = (LPTSTR) MapViewOfFileExNuma (mem->shm_fd, FILE_MAP_ALL_ACCESS, 0, 0, + size, base_ptr, NUMA_NO_PREFERRED_NODE); + if (mem->glbl.base == NULL) + { + perror ("MapViewOfFile failed"); + exit (1); + } +#endif + if (!base_ptr) + { +#define bufsize 20 + char buffer[bufsize]; + + snprintf (buffer, bufsize, "%p", mem->glbl.base); +#ifdef HAVE_SETENV + setenv (ENV_BASE, buffer, 1); +#else + SetEnvironmentVariable (ENV_BASE, buffer); +#endif +#undef bufsize + } + mem->size = size; + if (!env_val) + *mem->glbl.meta + = (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0}; +} + +void +shared_memory_cleanup (shared_memory_act *mem) +{ +#ifdef HAVE_MMAP + int res = munmap (mem->glbl.base, mem->size); + if (res) + { + perror ("unmapping shared memory segment failed"); + } + res = close (mem->shm_fd); + if (res) + { + perror ("closing shm file handle failed. Trying to continue..."); + } + if (this_image.image_num == -1) + { + char shm_name[NAME_MAX]; + + snprintf (shm_name, NAME_MAX, "/gfor-shm-%s", shared_memory_get_env ()); + /* Only the supervisor is to delete the shm-file. */ + res = shm_unlink (shm_name); + if (res == -1) + { + perror ("shm_unlink failed"); + exit (1); + } + } +#elif defined(WIN32) + if (!UnmapViewOfFile (mem->glbl.base)) + { + perror ("unmapping shared memory segment failed"); + } + CloseHandle (mem->shm_fd); +#endif +} +#undef NAME_MAX diff --git a/libgfortran/caf/shmem/shared_memory.h b/libgfortran/caf/shmem/shared_memory.h new file mode 100644 index 000000000000..3d031875ed2f --- /dev/null +++ b/libgfortran/caf/shmem/shared_memory.h @@ -0,0 +1,96 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#ifndef SHARED_MEMORY_H +#define SHARED_MEMORY_H + +#include "thread_support.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 + caf_shmem_fd shm_fd; +} shared_memory_act; + +/* A struct to serve as shared memory object. */ + +typedef struct shared_memory_act * shared_memory; + +#define SHMPTR_NULL ((shared_mem_ptr) {.offset = 0}) +#define SHMPTR_IS_NULL(x) (x.offset == 0) + +#define SHMPTR_DEREF(x, s, sm) ((x) = *(__typeof (x) *) s.p) +#define SHMPTR_AS(type, s, sm) ((type) (*((void **) sm) + s.offset)) +#define AS_SHMPTR(p, sm) ((shared_mem_ptr) {.offset = (p) - sm.glbl.base}) + +#define SHARED_MEMORY_RAW_ALLOC(mem, t, n) \ + shared_memory_get_mem_with_alignment (mem, sizeof (t) * n, __alignof__ (t)) + +#define SHARED_MEMORY_RAW_ALLOC_PTR(mem, t) \ + SHMPTR_AS (t *, SHARED_MEMORY_RAW_ALLOC (mem, t, 1), mem) + +/* A shared-memory pointer is implemented as an offset into the shared + memory region. */ + +typedef struct shared_mem_ptr +{ + ptrdiff_t offset; +} shared_mem_ptr; + +void shared_memory_init (shared_memory, size_t); + +void shared_memory_cleanup (shared_memory); + +void shared_memory_prepare (shared_memory); + +shared_mem_ptr shared_memory_get_mem_with_alignment (shared_memory mem, + size_t size, size_t align); + +shared_mem_ptr shared_memory_get_master (shared_memory pmem, size_t size, + size_t align); + +void shared_memory_set_env (pid_t pid); + +char *shared_memory_get_env (void); + +#endif diff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c new file mode 100644 index 000000000000..780ab4a45c04 --- /dev/null +++ b/libgfortran/caf/shmem/supervisor.c @@ -0,0 +1,550 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "../caf_error.h" +#include "supervisor.h" +#include "teams_mgmt.h" +#include "thread_support.h" + +#include +#include +#include +#include +#ifdef HAVE_WAIT_H +#include +#elif HAVE_SYS_WAIT_H +#include +#endif +#if !defined(_SC_PAGE_SIZE) && defined(WIN32) +#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" +#define GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS "GFORTRAN_IMAGE_RESTARTS_LIMIT" + +image_local *local = NULL; + +image this_image = {-1, NULL}; + +/* Get image number from environment or sysconf. */ + +static int +get_image_num_from_envvar (void) +{ + char *num_images_char; + int nimages; + num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES); + if (!num_images_char) +#ifdef _SC_NPROCESSORS_ONLN + return sysconf (_SC_NPROCESSORS_ONLN); +#elif defined(WIN32) + num_images_char = getenv ("NUMBER_OF_PROCESSORS"); +#else +#error "Unsupported system: No known way to get number of cores!" +#endif + nimages = atoi (num_images_char); + return nimages; +} + +/* Get the number of restarts allowed when the shared memory could not be placed +at the same location in each image. This is mostly important for MacOS, because +this OS acts somewhat arbitrary/indeterministic. */ + +static unsigned +get_image_restarts_limit (void) +{ + char *limit_chars; + unsigned limit = 4000; + limit_chars = getenv (GFORTRAN_ENV_IMAGE_RESTARTS_LIMITS); + if (limit_chars) + limit = atoi (limit_chars); + return limit; +} + +/* Get the amount of memory for the shared memory block. This is picked from + an environment variable. If that is not there, pick a reasonable default. + Note that on a 64-bit system which allows overcommit, there is no penalty in + reserving a large space and then not using it. */ + +static size_t +get_memory_size_from_envvar (void) +{ + char *e; + size_t sz = 0; + e = getenv (GFORTRAN_ENV_SHARED_MEMORY_SIZE); + if (e) + { + char suffix[2]; + int rv; + rv = sscanf (e, "%zu%1s", &sz, suffix); + if (rv == 2) + { + switch (suffix[0]) + { + case 'k': + case 'K': + sz *= ((size_t) 1) << 10; + break; + case 'm': + case 'M': + sz *= ((size_t) 1) << 20; + break; + case 'g': + case 'G': + sz *= ((size_t) 1) << 30; + break; + default: + sz = 0; + } + } + } + if (sz == 0) + { + /* Use 256 MB for 32-bit systems and 4 GB for 64-bit systems. */ + if (sizeof (size_t) == 4) + sz = ((size_t) 1) << 28; + else +#ifndef WIN32 + sz = ((size_t) 1) << 34; +#else + /* Use 1GB on Windows. */ + sz = ((size_t) 1) << 30; +#endif + } + return sz; +} + +/* Get a supervisor. */ + +static supervisor * +get_supervisor (void) +{ + supervisor *sv; + sv = SHMPTR_AS (supervisor *, + shared_memory_get_master (&local->sm, + sizeof (supervisor) + + sizeof (image_tracker) + * local->total_num_images, + __alignof__ (supervisor)), + &local->sm); + sv->failed_images = 0; + sv->finished_images = 0; + return sv; +} + +/* Defined in shmem.c, but we need it here. */ + +extern memid next_memid; + +#define SUPERVISOR_MAGIC_NUM 0x12345678 + +/* Ensure things are initialized. */ + +void +ensure_shmem_initialization (void) +{ + size_t shmem_size; + char *image_num; + + if (local) + return; + + local = malloc (sizeof (image_local)); + if (!local) + { + caf_runtime_error ("can not initialize memory for local cache"); + exit (1); + } +#if defined(_SC_PAGE_SIZE) + pagesize = sysconf (_SC_PAGE_SIZE); +#elif defined(WIN32) + { + SYSTEM_INFO si; + GetNativeSystemInfo (&si); + pagesize = si.dwAllocationGranularity; + } +#else +#warning \ + "Unsupported system: No known way to get memory page size. Assuming 4k!" + pagesize = 4096; +#endif + shmem_size = round_to_pagesize (get_memory_size_from_envvar ()); + local->total_num_images = get_image_num_from_envvar (); + shared_memory_init (&local->sm, shmem_size); + shared_memory_prepare (&local->sm); + + /* Shared memory needs to be present, before master can be initialized/linked + to. */ + image_num = getenv (GFORTRAN_ENV_IMAGE_NUM); + if (image_num) + { + bool created; + this_image = (image) {atoi (image_num), get_supervisor ()}; + assert (this_image.supervisor->magic_number == SUPERVISOR_MAGIC_NUM); + + alloc_init (&local->ai, &local->sm); + + caf_initial_team = caf_current_team + = (caf_shmem_team_t) calloc (1, sizeof (struct caf_shmem_team)); + allocator_lock (&local->ai.alloc); + *caf_initial_team = (struct caf_shmem_team) { + NULL, + -1, + this_image.image_num, + 0, + NULL, + {alloc_get_memory_by_id_created (&local->ai, + local->total_num_images * sizeof (int) + + sizeof (struct shmem_image_info), + next_memid++, &created)}}; + if (created) + { + counter_barrier_init (&caf_initial_team->u.image_info->image_count, + local->total_num_images); + collsub_init_supervisor (&caf_initial_team->u.image_info->collsub, + alloc_get_allocator (&local->ai), + local->total_num_images); + caf_initial_team->u.image_info->team_parent_id = 0; + caf_initial_team->u.image_info->team_id = -1; + caf_initial_team->u.image_info->image_map_size + = local->total_num_images; + caf_initial_team->u.image_info->num_term_images = 0; + caf_initial_team->u.image_info->lastmemid = 0; + for (int i = 0; i < local->total_num_images; ++i) + caf_initial_team->u.image_info->image_map[i] = i; + } + allocator_unlock (&local->ai.alloc); + sync_init (&local->si, &local->sm); + } + else + { + this_image = (image) {-1, get_supervisor ()}; + this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM; + thread_support_init_supervisor (); + counter_barrier_init (&this_image.supervisor->num_active_images, + local->total_num_images); + alloc_init_supervisor (&local->ai, &local->sm); + sync_init_supervisor (&local->si, &local->ai); + } +} + +#if !defined(environ) +extern char **environ; +#endif + +static bool +startWorker (image *im __attribute__ ((unused)), + char ***argv __attribute__ ((unused))) +{ +#ifdef HAVE_FORK + caf_shmem_pid new_pid; + if ((new_pid = fork ())) + { + im->supervisor->images[im->image_num] + = (image_tracker) {new_pid, IMAGE_OK}; + return false; + } + else + { + if (new_pid == -1) + caf_runtime_error ("error spawning child\n"); + static char **new_env; + static char num_image[32]; + size_t n = 2; /* Add one env-var and one for the term NULL. */ + + /* Count the number of entries in the current environment. */ + for (char **e = environ; *e; ++e, ++n) + ; + new_env = (char **) malloc (sizeof (char *) * n); + memcpy (new_env, environ, sizeof (char *) * (n - 2)); + snprintf (num_image, 32, "%s=%d", GFORTRAN_ENV_IMAGE_NUM, im->image_num); + new_env[n - 2] = num_image; + new_env[n - 1] = NULL; + if (execve ((*argv)[0], *argv, new_env) == -1) + { + perror ("execve failed"); + } + exit (255); + } +#endif + return true; +} + +#ifndef WIN32 +static void +kill_all_images (supervisor *m) +{ + for (int j = 0; j < local->total_num_images; j++) + if (m->images[j].status == IMAGE_OK) + kill (m->images[j].pid, SIGKILL); +} +#endif + +/* argc and argv may not be used on certain OSes. Flag them unused therefore. + */ +int +supervisor_main_loop (int *argc __attribute__ ((unused)), + char ***argv __attribute__ ((unused)), int *exit_code) +{ + supervisor *m; + image im; +#if defined(WIN32) && !defined(HAVE_FORK) + HANDLE *process_handles = malloc (sizeof (HANDLE) * local->total_num_images), + *thread_handles = malloc (sizeof (HANDLE) * local->total_num_images), + *waiting_handles = malloc (sizeof (HANDLE) * local->total_num_images); + int count_waiting = local->total_num_images; + LPTCH *envs = malloc (sizeof (LPTCH) * local->total_num_images); + LPTSTR currentDir; + DWORD cdLen = GetCurrentDirectory (0, NULL); + currentDir = malloc (cdLen); + GetCurrentDirectory (cdLen, currentDir); +#else + int chstatus; + unsigned restarts = 0, restarts_limit; + restarts_limit = get_image_restarts_limit (); +#endif + + *exit_code = 0; + shared_memory_set_env (getpid ()); + im.supervisor = m = this_image.supervisor; + + for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++) + { +#ifdef HAVE_FORK + if (startWorker (&im, argv)) + return 1; +#elif defined(WIN32) + LPTCH new_env; + size_t n = 0, es; + STARTUPINFO si; + DWORD dwFlags = 0; + PROCESS_INFORMATION pi; + LPTCH env = GetEnvironmentStrings (); + + ZeroMemory (&si, sizeof (si)); + si.cb = sizeof (si); + ZeroMemory (&pi, sizeof (pi)); + + /* Count the number of characters in the current environment. */ + for (LPTSTR e = (LPTSTR) env; *e; es = lstrlen (e) + 1, e += es, n += es) + ; + new_env = (LPCH) malloc (n + 32 * sizeof (TCHAR)); + memcpy (new_env, env, n); + snprintf (&((TCHAR *) new_env)[n], 32, "%s=%d%c", GFORTRAN_ENV_IMAGE_NUM, + im.image_num, (char) 0); + if (!CreateProcessA (NULL, GetCommandLine (), NULL, NULL, FALSE, dwFlags, + new_env, currentDir, &si, &pi)) + { + LPVOID lpMsgBuf; + DWORD dw = GetLastError (); + + if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER + | FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, dw, + MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &lpMsgBuf, 0, NULL) + == 0) + { + fprintf (stderr, "formatting the error message failed.\n"); + ExitProcess (dw); + } + + fprintf (stderr, "error spawning child: %ld, %s\n", dw, + (LPCTSTR) lpMsgBuf); + + LocalFree (lpMsgBuf); + exit (1); + } + m->images[im.image_num] = (image_tracker) {pi.hProcess, IMAGE_OK}; + process_handles[im.image_num] = waiting_handles[im.image_num] + = pi.hProcess; + thread_handles[im.image_num] = pi.hThread; + envs[im.image_num] = new_env; +#else +#error "no way known to start child processes." +#endif + } + for (int i = 0; i < local->total_num_images; i++) + { +#ifdef HAVE_FORK + caf_shmem_pid finished_pid = wait (&chstatus); + int j; + + if (finished_pid == -1) + { + /* Skip wait having an issue. */ + perror ("wait failed"); + --i; + continue; + } + if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus)) + { + for (j = 0; + j < local->total_num_images && m->images[j].pid != finished_pid; + j++) + ; + /* Only set the status, when it has not been set by the (failing) + image already. */ + if (m->images[j].status == IMAGE_OK) + { + m->images[j].status = IMAGE_SUCCESS; + atomic_fetch_add (&m->finished_images, 1); + } + } + else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus)) + { + for (j = 0; + j < local->total_num_images && m->images[j].pid != finished_pid; + j++) + ; + if (WEXITSTATUS (chstatus) == 210) + { + --i; + im.image_num = j; + ++restarts; + if (restarts > restarts_limit) + { + kill_all_images (m); + caf_runtime_error ( + "After restarting images %d times, no common state on " + "shared memory could be reached. Giving up...", + restarts); + exit (1); + } + if (startWorker (&im, argv)) + return 1; + continue; + } + else + { + dprintf (2, + "ERROR: Image %d(pid: %d) failed with signal %d, " + "exitstatus %d.\n", + j + 1, finished_pid, WTERMSIG (chstatus), + WEXITSTATUS (chstatus)); + if (j == local->total_num_images) + { + if (finished_pid == getpid ()) + { + dprintf ( + 2, + "WARNING: Supervisor process got signal %d. Killing " + "childs and exiting.\n", + WTERMSIG (chstatus)); + kill_all_images (m); + exit (1); + } + dprintf (2, + "WARNING: Got signal %d for unknown process %d. " + "Ignoring and trying to continue.\n", + WTERMSIG (chstatus), finished_pid); + continue; + } + m->images[j].status = IMAGE_FAILED; + atomic_fetch_add (&m->failed_images, 1); + if (*exit_code < WTERMSIG (chstatus)) + *exit_code = WTERMSIG (chstatus); + else if (*exit_code == 0) + *exit_code = 1; + } + } + /* Trigger waiting sync images aka sync_table. */ + for (j = 0; j < local->total_num_images; j++) + caf_shmem_cond_signal (&SHMPTR_AS (caf_shmem_condvar *, + m->sync_shared.sync_images_cond_vars, + &local->sm)[j]); + counter_barrier_add (&m->num_active_images, -1); +#elif defined(WIN32) + DWORD res = WaitForMultipleObjects (count_waiting, waiting_handles, FALSE, + INFINITE); + HANDLE cand; + bool progress = false; + DWORD process_exit_code; + if (res == WAIT_FAILED) + caf_runtime_error ("waiting for process termination failed."); + int index = res - WAIT_OBJECT_0, finished_process; + bool fail; + + do + { + cand = waiting_handles[index]; + for (finished_process = 0; + finished_process < local->total_num_images + && cand != process_handles[finished_process]; + ++finished_process) + ; + + GetExitCodeProcess (cand, &process_exit_code); + fail = process_exit_code != 0; + fprintf (stderr, "terminating process %d with fail status %d (%ld)\n", + finished_process, fail, process_exit_code); + if (finished_process < local->total_num_images) + { + CloseHandle (process_handles[finished_process]); + process_handles[finished_process] = NULL; + CloseHandle (thread_handles[finished_process]); + FreeEnvironmentStrings (envs[finished_process]); + if (fail) + { + m->images[finished_process].status = IMAGE_FAILED; + atomic_fetch_add (&m->failed_images, 1); + if (*exit_code < process_exit_code) + *exit_code = process_exit_code; + } + else + { + m->images[finished_process].status = IMAGE_SUCCESS; + atomic_fetch_add (&m->finished_images, 1); + } + } + memmove (&waiting_handles[index], &waiting_handles[index + 1], + sizeof (HANDLE) * (count_waiting - index - 1)); + --count_waiting; + counter_barrier_add (&m->num_active_images, -1); + + /* Check if more than one process has terminated already. */ + progress = false; + for (index = 0; index < count_waiting; ++index) + if (WaitForSingleObject (waiting_handles[index], 0) + == WAIT_OBJECT_0) + { + progress = true; + ++i; + break; + } + } + while (progress && count_waiting > 0); +#endif + } + +#if defined(WIN32) && !defined(HAVE_FORK) + free (process_handles); + free (thread_handles); + free (envs); +#endif + return 0; +} diff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h new file mode 100644 index 000000000000..7e5e19702e45 --- /dev/null +++ b/libgfortran/caf/shmem/supervisor.h @@ -0,0 +1,119 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#ifndef SUPERVISOR_H +#define SUPERVISOR_H + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include "caf/libcaf.h" +#include "alloc.h" +#include "collective_subroutine.h" +#include "sync.h" + +#include + +typedef enum +{ + IMAGE_UNKNOWN = 0, + IMAGE_OK, + IMAGE_FAILED, + IMAGE_SUCCESS +} image_status; + +typedef struct +{ + caf_shmem_pid pid; + image_status status; +} image_tracker; + +typedef struct supervisor +{ + ptrdiff_t magic_number; + alloc_shared alloc_shared; + hashmap_shared hms; + collsub_shared collsub_shared; + sync_shared sync_shared; + atomic_int failed_images; + atomic_int finished_images; + counter_barrier num_active_images; + caf_shmem_mutex image_tracker_lock; +#ifdef WIN32 + size_t global_used_handles; +#endif + image_tracker images[]; +} supervisor; + +typedef struct +{ + int image_num; + supervisor *supervisor; +} image; + +extern image this_image; + +typedef struct +{ + int total_num_images; + struct shared_memory_act sm; + alloc ai; + sync_t si; +} image_local; + +extern image_local *local; + +struct caf_shmem_token +{ + /* The pointer to the memory registered for the current image. For arrays + this is the data member in the descriptor. For components it's the pure + data pointer. */ + void *memptr; + /* The descriptor when this token is associated to an allocatable array. */ + gfc_descriptor_t *desc; + /* The base address this coarray's memory in the shared memory space. The + base address of image I is computed by base + I * image_size. */ + void *base; + /* The size of memory in each image aligned on pointer borders, i.e. each + images memory starts on an address that is aligned to enable maximum speed + for the processor architecure used. */ + size_t image_size; + /* The id of this token. */ + memid token_id; + /* Set when the caf lib has allocated the memory in memptr and is responsible + for freeing it on deregister. */ + bool owning_memory; +}; +typedef struct caf_shmem_token *caf_shmem_token_t; + + +/* Ensure the shared memory environment is up and all support structures are + initialized and linked correctly. */ + +void ensure_shmem_initialization (void); + +int supervisor_main_loop (int *argc, char ***argv, int *exit_code); + +#endif diff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c new file mode 100644 index 000000000000..e1020a1e8640 --- /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) +{ + caf_shmem_mutex_lock (&si->cis->sync_images_table_lock); +} + +static inline void +unlock_table (sync_t *si) +{ + caf_shmem_mutex_unlock (&si->cis->sync_images_table_lock); +} + +void +sync_init (sync_t *si, shared_memory sm) +{ + *si = (sync_t) { + &this_image.supervisor->sync_shared, + SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm), + SHMPTR_AS (caf_shmem_condvar *, + this_image.supervisor->sync_shared.sync_images_cond_vars, sm)}; +} + +void +sync_init_supervisor (sync_t *si, alloc *ai) +{ + const int num_images = local->total_num_images; + const size_t table_size_in_bytes = sizeof (int) * num_images * num_images; + + si->cis = &this_image.supervisor->sync_shared; + + initialize_shared_mutex (&si->cis->event_lock); + initialize_shared_condition (&si->cis->event_cond, num_images); + + initialize_shared_mutex (&si->cis->sync_images_table_lock); + + si->cis->sync_images_table + = allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes); + si->cis->sync_images_cond_vars + = allocator_shared_malloc (alloc_get_allocator (ai), + sizeof (caf_shmem_condvar) * num_images); + + si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem); + si->triggers + = SHMPTR_AS (caf_shmem_condvar *, si->cis->sync_images_cond_vars, ai->mem); + + for (int i = 0; i < num_images; i++) + initialize_shared_condition (&si->triggers[i], num_images); + + memset (si->table, 0, table_size_in_bytes); +} + +void +sync_table (sync_t *si, int *images, int size) +{ + /* The variable `table` is an N x N matrix, where N is the number of all + images. The position (i, j) (where i and j are always the real images + index, i.e. after team de-mapping) tells whether image i has seen the same + number of synchronisation calls to sync_table like j. When table(i,j) == + table(j,i) then the sync for i with this image is completed (here j is the + real image index of the current image). When this holds for all i in the + current set of images (or all images, if the set is empty), then sync table + command is completed. + */ + volatile int *table = si->table; + int i; + + lock_table (si); + if (size > 0) + { + const size_t img_c = caf_current_team->u.image_info->image_map_size; + for (i = 0; i < size; ++i) + { + ++table[images[i] + img_c * this_image.image_num]; + caf_shmem_cond_signal (&si->triggers[images[i]]); + } + for (;;) + { + for (i = 0; i < size; ++i) + if (this_image.supervisor->images[images[i]].status == IMAGE_OK + && table[images[i] + this_image.image_num * img_c] + > table[this_image.image_num + images[i] * img_c]) + break; + if (i == size) + break; + caf_shmem_cond_wait (&si->triggers[this_image.image_num], + &si->cis->sync_images_table_lock); + } + } + else + { + int *map = caf_current_team->u.image_info->image_map; + size = caf_current_team->u.image_info->image_count.count; + for (i = 0; i < size; ++i) + { + if (this_image.supervisor->images[map[i]].status != IMAGE_OK) + continue; + ++table[map[i] + size * this_image.image_num]; + caf_shmem_cond_signal (&si->triggers[map[i]]); + } + for (;;) + { + for (i = 0; i < size; ++i) + if (this_image.supervisor->images[map[i]].status == IMAGE_OK + && table[map[i] + size * this_image.image_num] + > table[this_image.image_num + map[i] * size]) + break; + if (i == size) + break; + caf_shmem_cond_wait (&si->triggers[this_image.image_num], + &si->cis->sync_images_table_lock); + } + } + unlock_table (si); +} + +void +sync_all (void) +{ + counter_barrier_wait (&caf_current_team->u.image_info->image_count); +} + +void +sync_team (caf_shmem_team_t team) +{ + counter_barrier_wait (&team->u.image_info->image_count); +} + +void +lock_event (sync_t *si) +{ + caf_shmem_mutex_lock (&si->cis->event_lock); +} + +void +unlock_event (sync_t *si) +{ + caf_shmem_mutex_unlock (&si->cis->event_lock); +} + +void +event_post (sync_t *si) +{ + caf_shmem_cond_broadcast (&si->cis->event_cond); +} + +void +event_wait (sync_t *si) +{ + caf_shmem_cond_wait (&si->cis->event_cond, &si->cis->event_lock); +} diff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h new file mode 100644 index 000000000000..a6d20614b675 --- /dev/null +++ b/libgfortran/caf/shmem/sync.h @@ -0,0 +1,77 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#ifndef SYNC_H +#define SYNC_H + +#include "alloc.h" +#include "counter_barrier.h" + +typedef struct { + /* Mutex and condition variable needed for signaling events. */ + caf_shmem_mutex event_lock; + caf_shmem_condvar event_cond; + caf_shmem_mutex sync_images_table_lock; + shared_mem_ptr sync_images_table; + shared_mem_ptr sync_images_cond_vars; +} sync_shared; + +typedef struct { + sync_shared *cis; + int *table; // we can cache the table and the trigger pointers here + caf_shmem_condvar *triggers; +} sync_t; + +typedef caf_shmem_mutex lock_t; + +typedef int event_t; + +void sync_init (sync_t *, shared_memory); + +void sync_init_supervisor (sync_t *, alloc *); + +void sync_all (void); + +/* Prototype for circular dependency break. */ + +struct caf_shmem_team; +typedef struct caf_shmem_team *caf_shmem_team_t; + +void sync_team (caf_shmem_team_t team); + +void sync_table (sync_t *, int *, int); + +void lock_alloc_lock (sync_t *); + +void unlock_alloc_lock (sync_t *); + +void lock_event (sync_t *); + +void unlock_event (sync_t *); + +void event_post (sync_t *); + +void event_wait (sync_t *); + +#endif diff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c new file mode 100644 index 000000000000..9bf8db2302c2 --- /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) +{ + caf_shmem_mutex_lock (&team->u.image_info->image_count.mutex); + if (team->u.image_info->num_term_images + != this_image.supervisor->finished_images + + this_image.supervisor->failed_images) + { + const int old_num = team->u.image_info->num_term_images; + const int sz = team->u.image_info->image_map_size; + int i, good = 0; + + for (i = 0; i < sz; ++i) + if (this_image.supervisor->images[team->u.image_info->image_map[i]] + .status + == IMAGE_OK) + ++good; + + team->u.image_info->num_term_images = sz - good; + + counter_barrier_add_locked (&team->u.image_info->image_count, + old_num + - team->u.image_info->num_term_images); + } + caf_shmem_mutex_unlock (&team->u.image_info->image_count.mutex); +} + +void +check_health (int *stat, char *errmsg, size_t errmsg_len) +{ + if (this_image.supervisor->finished_images + || this_image.supervisor->failed_images) + { + if (this_image.supervisor->finished_images) + { + caf_internal_error ("Stopped images present (currently %d)", stat, + errmsg, errmsg_len, + this_image.supervisor->finished_images); + if (stat) + *stat = CAF_STAT_STOPPED_IMAGE; + } + else if (this_image.supervisor->failed_images) + { + caf_internal_error ("Failed images present (currently %d)", stat, + errmsg, errmsg_len, + this_image.supervisor->failed_images); + if (stat) + *stat = CAF_STAT_FAILED_IMAGE; + } + } + else if (stat) + *stat = 0; +} diff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h new file mode 100644 index 000000000000..f96f4aea33e6 --- /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 100755 index 000000000000..dcd8b00b7888 --- /dev/null +++ b/libgfortran/caf/shmem/thread_support.c @@ -0,0 +1,381 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "thread_support.h" + +#include +#include +#include + +#if !defined(WIN32) && !defined(__CYGWIN__) +#include + +#define ERRCHECK(a) \ + do \ + { \ + int rc = a; \ + if (rc) \ + { \ + errno = rc; \ + perror (#a " failed"); \ + exit (1); \ + } \ + } \ + while (0) + +void +initialize_shared_mutex (caf_shmem_mutex *mutex) +{ + pthread_mutexattr_t mattr; + ERRCHECK (pthread_mutexattr_init (&mattr)); + ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED)); +#ifdef PTHREAD_MUTEX_ROBUST + ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST)); +#endif + ERRCHECK (pthread_mutex_init (mutex, &mattr)); + ERRCHECK (pthread_mutexattr_destroy (&mattr)); +} + +void +initialize_shared_errorcheck_mutex (caf_shmem_mutex *mutex) +{ + pthread_mutexattr_t mattr; + ERRCHECK (pthread_mutexattr_init (&mattr)); + ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK)); + ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED)); +#ifdef PTHREAD_MUTEX_ROBUST + ERRCHECK (pthread_mutexattr_setrobust (&mattr, PTHREAD_MUTEX_ROBUST)); +#endif + ERRCHECK (pthread_mutex_init (mutex, &mattr)); + ERRCHECK (pthread_mutexattr_destroy (&mattr)); +} + +void +initialize_shared_condition (caf_shmem_condvar *cond, const int) +{ + pthread_condattr_t cattr; + ERRCHECK (pthread_condattr_init (&cattr)); + ERRCHECK (pthread_condattr_setpshared (&cattr, PTHREAD_PROCESS_SHARED)); + ERRCHECK (pthread_cond_init (cond, &cattr)); + ERRCHECK (pthread_condattr_destroy (&cattr)); +} +#else +#include "../caf_error.h" +#include "supervisor.h" +#include "teams_mgmt.h" +#include +#include + +static HANDLE *handles = NULL; +static size_t cap_handles = 0; + +static const int ULONGBITS = sizeof (unsigned long) << 3; // *8 + +static size_t +smax (size_t a, size_t b) +{ + return a < b ? b : a; +} + +static HANDLE +get_handle (const size_t id, const char t) +{ + const int add = t == 'c' ? 1 : 0; + while (id + add >= cap_handles) + { + cap_handles += 1024; + if (handles) + handles = realloc (handles, sizeof (HANDLE) * cap_handles); + else + handles = malloc (sizeof (HANDLE) * cap_handles); + if (!handles) + caf_runtime_error ( + "can not get buffer for synchronication objects, aborting"); + + memset (&handles[cap_handles - 1024], 0, sizeof (HANDLE) * 1024); + } + if (!handles[id]) + { + static char *pid = NULL; + char name[MAX_PATH]; + + if (!pid) + pid = shared_memory_get_env (); + snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd", pid, t, id); + switch (t) + { + case 'm': + handles[id] = CreateMutex (NULL, false, name); + break; + case 'c': + { + handles[id] = CreateSemaphore (NULL, 0, __INT_MAX__, name); + snprintf (name, MAX_PATH, "Global_gfortran-%s-%c-%zd_lock", pid, t, + id); + handles[id + 1] = CreateSemaphore (NULL, 1, 1, name); + this_image.supervisor->global_used_handles + = smax (this_image.supervisor->global_used_handles, id + 2); + break; + } + default: + caf_runtime_error ("Unknown handle type %c", t); + exit (1); + } + if (handles[id] == NULL) + { + caf_runtime_error ( + "Could not create synchronisation object, error: %d", + GetLastError ()); + return NULL; + } + + this_image.supervisor->global_used_handles + = smax (this_image.supervisor->global_used_handles, id + 1); + } + + return handles[id]; +} + +static HANDLE +get_mutex (caf_shmem_mutex *m) +{ + return get_handle (m->id, 'm'); +} + +static HANDLE +get_condvar (caf_shmem_condvar *cv) +{ + return get_handle (cv->id, 'c'); +} + +void +thread_support_init_supervisor (void) +{ + if (local->total_num_images > ULONGBITS * MAX_NUM_SIGNALED) + caf_runtime_error ("Maximum number of supported images is %zd.", + ULONGBITS * MAX_NUM_SIGNALED); + this_image.supervisor->global_used_handles = 0; +} + +int +caf_shmem_mutex_lock (caf_shmem_mutex *m) +{ + HANDLE mutex = get_mutex (m); + DWORD res = WaitForSingleObject (mutex, INFINITE); + + /* Return zero on success. */ + return res != WAIT_OBJECT_0; +} + +int +caf_shmem_mutex_trylock (caf_shmem_mutex *m) +{ + HANDLE mutex = get_mutex (m); + DWORD res = WaitForSingleObject (mutex, 0); + + return res == WAIT_OBJECT_0 ? 0 : EBUSY; +} + +int +caf_shmem_mutex_unlock (caf_shmem_mutex *m) +{ + HANDLE mutex = get_mutex (m); + BOOL res = ReleaseMutex (mutex); + + if (!res) + { + LPVOID lpMsgBuf; + DWORD dw = GetLastError (); + + if (FormatMessage (FORMAT_MESSAGE_ALLOCATE_BUFFER + | FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, dw, MAKELANGID (LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &lpMsgBuf, 0, NULL) + == 0) + { + fprintf (stderr, "%d: formatting the error message failed.\n", + this_image.image_num); + ExitProcess (dw); + } + + fprintf (stderr, "%d: unlock mutex failed: %d, %s\n", + this_image.image_num, dw, (LPCTSTR) lpMsgBuf); + + LocalFree (lpMsgBuf); + } + return res ? 0 : EPERM; +} + +static bool +bm_is_set (volatile unsigned long mask[], const int b) +{ + return (mask[b / ULONGBITS] & (1UL << (b % ULONGBITS))) != 0; +} + +static void +bm_clear_bit (volatile unsigned long mask[], const int b) +{ + mask[b / ULONGBITS] &= ~(1UL << (b % ULONGBITS)); +} + +static void +bm_set_mask (volatile unsigned long mask[], const int size) +{ + const int entries = size / ULONGBITS; + const int rem = size % ULONGBITS; + int i = 0; + assert (entries >= 0); + + for (; i < entries; ++i) + mask[i] = ~0UL; + if (rem != 0) + mask[i] = ~0UL >> (ULONGBITS - rem); +} + +__attribute__ ((used)) static bool +bm_is_none (volatile unsigned long mask[], const int size) +{ + const int entries = size / ULONGBITS; + const int rem = size % ULONGBITS; + int i = 0; + for (; i < entries; ++i) + if (mask[i] != 0) + return false; + + return rem == 0 || ((mask[i] & (~0UL >> (ULONGBITS - rem))) == 0); +} + +void +caf_shmem_cond_wait (caf_shmem_condvar *cv, caf_shmem_mutex *m) +{ + HANDLE mutex = get_mutex (m), condvar = get_condvar (cv), + lock = get_handle (cv->id + 1, 'c'); + HANDLE entry[3] = {mutex, condvar, lock}; + int res; + + WaitForSingleObject (lock, INFINITE); + for (;;) + { + if (bm_is_set (cv->signaled, this_image.image_num) || cv->any) + { + break; + } + ReleaseMutex (mutex); + ReleaseSemaphore (lock, 1, NULL); + res = WaitForMultipleObjects (3, entry, true, INFINITE); + if (res != WAIT_OBJECT_0) + { + fprintf (stderr, "%d: failed to get all wait for: %d\n", + this_image.image_num, res); + fflush (stderr); + } + ReleaseSemaphore (condvar, 1, NULL); + } + res = WaitForSingleObject (condvar, INFINITE); + if (res != WAIT_OBJECT_0) + { + fprintf (stderr, "%d: failed to get condvar: %d\n", this_image.image_num, + res); + fflush (stderr); + } + + bm_clear_bit (cv->signaled, this_image.image_num); + cv->any = 0; + ReleaseSemaphore (lock, 1, NULL); +} + +void +caf_shmem_cond_broadcast (caf_shmem_condvar *cv) +{ + HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c'); + + WaitForSingleObject (lock, INFINITE); + bm_set_mask (cv->signaled, cv->size); + bm_clear_bit (cv->signaled, this_image.image_num); + + ReleaseSemaphore (condvar, cv->size, NULL); + ReleaseSemaphore (lock, 1, NULL); +} + +void +caf_shmem_cond_signal (caf_shmem_condvar *cv) +{ + HANDLE condvar = get_condvar (cv), lock = get_handle (cv->id + 1, 'c'); + + if (caf_current_team) + { + WaitForSingleObject (lock, INFINITE); + } + else + return; + /* The first image is zero, which wouldn't allow it to signal. */ + cv->any = this_image.image_num + 1; + ReleaseSemaphore (condvar, 1, NULL); + ReleaseSemaphore (lock, 1, NULL); +} + +void +caf_shmem_cond_update_count (caf_shmem_condvar *cv, int val) +{ + cv->size += val; +} + +void +initialize_shared_mutex (caf_shmem_mutex *m) +{ + *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles}; + + get_mutex (m); +} + +void +initialize_shared_errorcheck_mutex (caf_shmem_mutex *m) +{ + *m = (caf_shmem_mutex) {this_image.supervisor->global_used_handles}; + + get_mutex (m); +} + +void +initialize_shared_condition (caf_shmem_condvar *cv, const int size) +{ + *cv = (caf_shmem_condvar) {this_image.supervisor->global_used_handles, + 0, + size, + {}}; + + memset ((void *) cv->signaled, 0, sizeof (unsigned long) * MAX_NUM_SIGNALED); + get_condvar (cv); + assert (bm_is_none (cv->signaled, cv->size)); +} + +void +thread_support_cleanup (void) +{ + for (size_t i = 0; i < this_image.supervisor->global_used_handles; ++i) + if (handles[i]) + CloseHandle (handles[i]); +} +#endif diff --git a/libgfortran/caf/shmem/thread_support.h b/libgfortran/caf/shmem/thread_support.h new file mode 100755 index 000000000000..351cdbbb8687 --- /dev/null +++ b/libgfortran/caf/shmem/thread_support.h @@ -0,0 +1,113 @@ +/* Copyright (C) 2025 Free Software Foundation, Inc. + Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild + +This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem). + +Caf_shmem is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +Caf_shmem is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#ifndef THREAD_SUPPORT_H +#define THREAD_SUPPORT_H + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#ifndef WIN32 +#include + +typedef pid_t caf_shmem_pid; +typedef int caf_shmem_fd; +#else +#include + +typedef HANDLE caf_shmem_pid; +typedef HANDLE caf_shmem_fd; +#endif + +#if !defined(WIN32) && !defined(__CYGWIN__) +#include + +typedef pthread_mutex_t caf_shmem_mutex; +typedef pthread_cond_t caf_shmem_condvar; + +#define CAF_SHMEM_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER +#define CAF_SHMEM_COND_INITIALIZER PTHREAD_COND_INITIALIZER + +#define thread_support_init_supervisor() (void) 0 + +#define caf_shmem_mutex_lock pthread_mutex_lock +#define caf_shmem_mutex_trylock pthread_mutex_trylock +#define caf_shmem_mutex_unlock pthread_mutex_unlock + +#define caf_shmem_cond_wait pthread_cond_wait +#define caf_shmem_cond_broadcast pthread_cond_broadcast +#define caf_shmem_cond_signal pthread_cond_signal +#define caf_shmem_cond_update_count(c, v) (void) 0 + +#define thread_support_cleanup() (void) 0 +#else +#include +#include + +typedef struct caf_shmem_mutex +{ + size_t id; +} caf_shmem_mutex; + +#define MAX_NUM_SIGNALED 8 + +typedef struct caf_shmem_condvar +{ + size_t id; + volatile int any; + int size; + volatile unsigned long signaled[MAX_NUM_SIGNALED]; +} caf_shmem_condvar; + +#define CAF_SHMEM_MUTEX_INITIALIZER (caf_shmem_mutex){0} +#define CAF_SHMEM_COND_INITIALIZER \ + (caf_shmem_condvar) \ + { \ + 0, 0, 0, {} \ + } + +void thread_support_init_supervisor (void); + +int caf_shmem_mutex_lock (caf_shmem_mutex *); +int caf_shmem_mutex_trylock (caf_shmem_mutex *); +int caf_shmem_mutex_unlock (caf_shmem_mutex *); + +void caf_shmem_cond_wait (caf_shmem_condvar *, caf_shmem_mutex *); +void caf_shmem_cond_broadcast (caf_shmem_condvar *); +void caf_shmem_cond_signal (caf_shmem_condvar *); +void caf_shmem_cond_update_count (caf_shmem_condvar *, int); + +void thread_support_cleanup (void); +#endif + +/* Support routines to setup pthread structs in shared memory. */ + +void initialize_shared_mutex (caf_shmem_mutex *); + +void initialize_shared_errorcheck_mutex (caf_shmem_mutex *); + +void initialize_shared_condition (caf_shmem_condvar *, const int size); + +#endif diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 97876fa9d8c2..a6576f28260c 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); } diff --git a/libgfortran/config.h.in b/libgfortran/config.h.in index da2c44c1af1a..1a66ee7e5134 100644 --- a/libgfortran/config.h.in +++ b/libgfortran/config.h.in @@ -777,6 +777,9 @@ /* Define to 1 if you have the `mkstemp' function. */ #undef HAVE_MKSTEMP +/* Define to 1 if you have the `mmap' function. */ +#undef HAVE_MMAP + /* Define to 1 if you have the `newlocale' function. */ #undef HAVE_NEWLOCALE @@ -828,6 +831,9 @@ /* Define to 1 if you have the `roundl' function. */ #undef HAVE_ROUNDL +/* Define if __builtin_clzl behaves as expected. */ +#undef HAVE_SANE_BUILTIN_CLZL + /* Define to 1 if you have the `scalbn' function. */ #undef HAVE_SCALBN @@ -843,6 +849,9 @@ /* Define to 1 if you have the `secure_getenv' function. */ #undef HAVE_SECURE_GETENV +/* Define to 1 if you have the `setenv' function. */ +#undef HAVE_SETENV + /* Define to 1 if you have the `setmode' function. */ #undef HAVE_SETMODE @@ -945,6 +954,9 @@ /* Define to 1 if you have the `symlink' function. */ #undef HAVE_SYMLINK +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_MMAN_H + /* Define to 1 if you have the header file. */ #undef HAVE_SYS_RANDOM_H diff --git a/libgfortran/configure b/libgfortran/configure index 9898a94a372a..bdfb0f0317bc 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -637,6 +637,8 @@ am__EXEEXT_TRUE LTLIBOBJS LIBOBJS get_gcc_base_ver +HAVE_SANE_BUILTIN_CLZL_FALSE +HAVE_SANE_BUILTIN_CLZL_TRUE HAVE_AVX128_FALSE HAVE_AVX128_TRUE tmake_file @@ -2619,6 +2621,7 @@ as_fn_append ac_header_list " fpxcp.h" as_fn_append ac_header_list " pwd.h" as_fn_append ac_header_list " complex.h" as_fn_append ac_header_list " xlocale.h" +as_fn_append ac_header_list " sys/mman.h" as_fn_append ac_func_list " getrusage" as_fn_append ac_func_list " times" as_fn_append ac_func_list " mkstemp" @@ -2638,6 +2641,8 @@ as_fn_append ac_func_list " sleep" as_fn_append ac_func_list " ttyname" as_fn_append ac_func_list " sigaction" as_fn_append ac_func_list " waitpid" +as_fn_append ac_func_list " mmap" +as_fn_append ac_func_list " setenv" as_fn_append ac_func_list " alarm" as_fn_append ac_func_list " access" as_fn_append ac_func_list " fork" @@ -12847,7 +12852,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 12850 "configure" +#line 12855 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -12953,7 +12958,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 12956 "configure" +#line 12961 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -16738,6 +16743,8 @@ done + + @@ -17339,6 +17346,10 @@ done + + + + @@ -31438,6 +31449,57 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$ac_save_CFLAGS" +# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64). + + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run test program while cross compiling +See \`config.log' for more details" "$LINENO" 5; } +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + int main() + { + return __builtin_clzl(256) != 8; + } +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +$as_echo "#define HAVE_SANE_BUILTIN_CLZL 1" >>confdefs.h + + if true; then + HAVE_SANE_BUILTIN_CLZL_TRUE= + HAVE_SANE_BUILTIN_CLZL_FALSE='#' +else + HAVE_SANE_BUILTIN_CLZL_TRUE='#' + HAVE_SANE_BUILTIN_CLZL_FALSE= +fi + +else + if false; then + HAVE_SANE_BUILTIN_CLZL_TRUE= + HAVE_SANE_BUILTIN_CLZL_FALSE='#' +else + HAVE_SANE_BUILTIN_CLZL_TRUE='#' + HAVE_SANE_BUILTIN_CLZL_FALSE= +fi + +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + + # Determine what GCC version number to use in filesystem paths. get_gcc_base_ver="cat" @@ -31729,6 +31791,14 @@ if test -z "${HAVE_AVX128_TRUE}" && test -z "${HAVE_AVX128_FALSE}"; then as_fn_error $? "conditional \"HAVE_AVX128\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi +if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then + as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi +if test -z "${HAVE_SANE_BUILTIN_CLZL_TRUE}" && test -z "${HAVE_SANE_BUILTIN_CLZL_FALSE}"; then + as_fn_error $? "conditional \"HAVE_SANE_BUILTIN_CLZL\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 +fi : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 diff --git a/libgfortran/configure.ac b/libgfortran/configure.ac index cca1ea0ea970..b165dff1e050 100644 --- a/libgfortran/configure.ac +++ b/libgfortran/configure.ac @@ -298,7 +298,7 @@ AC_CHECK_TYPES([ptrdiff_t]) AC_CHECK_HEADERS_ONCE(unistd.h sys/random.h sys/time.h sys/times.h \ sys/resource.h sys/types.h sys/stat.h sys/uio.h sys/wait.h \ floatingpoint.h ieeefp.h fenv.h fptrap.h \ -fpxcp.h pwd.h complex.h xlocale.h) +fpxcp.h pwd.h complex.h xlocale.h sys/mman.h) GCC_HEADER_STDINT(gstdint.h) @@ -334,7 +334,7 @@ if test "${hardwire_newlib:-0}" -eq 1; then else AC_CHECK_FUNCS_ONCE(getrusage times mkstemp strtof strtold snprintf \ ftruncate chsize chdir getentropy getlogin gethostname kill link symlink \ - sleep ttyname sigaction waitpid \ + sleep ttyname sigaction waitpid mmap setenv\ alarm access fork posix_spawn setmode fcntl writev \ gettimeofday stat fstat lstat getpwuid vsnprintf dup \ getcwd localtime_r gmtime_r getpwuid_r ttyname_r clock_gettime \ @@ -789,6 +789,9 @@ LIBGFOR_CHECK_FMA4 # Check if AVX128 works LIBGFOR_CHECK_AVX128 +# Check if __builtin_clzl behaves (it doesn't on Msys2/ucrt64). +LIBGFOR_CHECK_SANE_BUILTIN_CLZL + # Determine what GCC version number to use in filesystem paths. GCC_BASE_VER