diff --git a/sys-cluster/opencoarrays/Manifest b/sys-cluster/opencoarrays/Manifest index 8442a48175..3c465f7de9 100644 --- a/sys-cluster/opencoarrays/Manifest +++ b/sys-cluster/opencoarrays/Manifest @@ -1 +1 @@ -DIST OpenCoarrays-2.10.3.tar.gz 351175 BLAKE2B 8398ec1000358b495f7c126b40eb12fc742cb796c9da8fb04bbffdf13bc9f5fa42d029312a751505db63700d1be33d7ff9a18a124789a3580f88204a1b02aac3 SHA512 4daf632f6ca32b96e1a81504caef94535926552c194e6a509182f5182e4f88aecf2012d3e044a821b6c4c9a88945af1735ca900411c920f902763ad1323031e1 +DIST OpenCoarrays-2.10.3_p20251223.tar.gz 351175 BLAKE2B 8398ec1000358b495f7c126b40eb12fc742cb796c9da8fb04bbffdf13bc9f5fa42d029312a751505db63700d1be33d7ff9a18a124789a3580f88204a1b02aac3 SHA512 4daf632f6ca32b96e1a81504caef94535926552c194e6a509182f5182e4f88aecf2012d3e044a821b6c4c9a88945af1735ca900411c920f902763ad1323031e1 diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_01_Improve_teams_implementation.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_01_Improve_teams_implementation.patch new file mode 100644 index 0000000000..48a594e03e --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_01_Improve_teams_implementation.patch @@ -0,0 +1,1300 @@ +From 27a6a400958696d778f73adcdea13dd2b8a189ba Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Fri, 28 Mar 2025 14:59:24 +0100 +Subject: [PATCH] Improve teams implementation + +Improve the implementation of team's functions to adhere to the Fortran +2018 standard and gfortran from 16 on. +--- + CMakeLists.txt | 13 +- + src/application-binary-interface/libcaf.h | 43 +- + src/runtime-libraries/mpi/mpi_caf.c | 569 +++++++++++++++--- + src/tests/unit/teams/CMakeLists.txt | 7 +- + src/tests/unit/teams/team_number.f90 | 68 +++ + ...{team-number.f90 => team_number_pre15.f90} | 0 + src/tests/unit/teams/teams_num_images.f90 | 52 ++ + src/tests/unit/teams/teams_this_image.f90 | 108 ++++ + 8 files changed, 759 insertions(+), 101 deletions(-) + create mode 100644 src/tests/unit/teams/team_number.f90 + rename src/tests/unit/teams/{team-number.f90 => team_number_pre15.f90} (100%) + create mode 100644 src/tests/unit/teams/teams_num_images.f90 + create mode 100644 src/tests/unit/teams/teams_this_image.f90 + +diff --git a/CMakeLists.txt b/CMakeLists.txt +index 8f9a736d1..888613454 100644 +--- a/CMakeLists.txt ++++ b/CMakeLists.txt +@@ -233,9 +233,12 @@ endif() + if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8.0.0 ) ) + add_definitions(-DGCC_GE_8) # Tell library to build against GFortran 8.x bindings w/ descriptor change + endif() +- if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 14.0.0 ) ) ++ if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 15.0.0 ) ) + add_definitions(-DGCC_GE_15) # Tell library to build against GFortran 15.x bindings + endif() ++ if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0.0 ) ) ++ add_definitions(-DGCC_GE_16) # Tell library to build against GFortran 16.x bindings ++ endif() + + if(gfortran_compiler) + set(OLD_REQUIRED_FLAGS ${CMAKE_REQUIRED_FLAGS}) +@@ -803,7 +806,6 @@ if(opencoarrays_aware_compiler) + add_caf_test(comp_allocated_2 2 comp_allocated_2) + add_caf_test(alloc_comp_get_convert_nums 2 alloc_comp_get_convert_nums) + if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8) +- add_caf_test(team_number 8 team_number) + add_caf_test(teams_subset 3 teams_subset) + add_caf_test(get_communicator 3 get_communicator) + add_caf_test(teams_coarray_get 5 teams_coarray_get) +@@ -815,6 +817,13 @@ if(opencoarrays_aware_compiler) + add_caf_test(alloc_comp_multidim_shape 2 alloc_comp_multidim_shape) + set_tests_properties(alloc_comp_multidim_shape PROPERTIES TIMEOUT 300) + endif() ++ if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 15) ++ add_caf_test(team_number 8 team_number) ++ add_caf_test(teams_this_image 8 teams_this_image) ++ add_caf_test(teams_num_images 8 teams_num_images) ++ else() ++ add_caf_test(team_number_pre15 8 team_number_pre15) ++ endif() + endif() + + if (gfortran_compiler) +diff --git a/src/application-binary-interface/libcaf.h b/src/application-binary-interface/libcaf.h +index 8add806df..66a93767d 100644 +--- a/src/application-binary-interface/libcaf.h ++++ b/src/application-binary-interface/libcaf.h +@@ -65,6 +65,17 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + #define STAT_STOPPED_IMAGE 6000 + #define STAT_FAILED_IMAGE 6001 + ++#ifdef GCC_GE_16 ++/* Definitions of the Fortran 2018 standard; need to kept in sync with ++ ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */ ++typedef enum ++{ ++ CAF_INITIAL_TEAM = 0, ++ CAF_PARENT_TEAM, ++ CAF_CURRENT_TEAM ++} caf_team_level_t; ++#endif ++ + /* Describes what type of array we are registerring. Keep in sync with + gcc/fortran/trans.h. */ + typedef enum caf_register_t +@@ -88,24 +99,12 @@ typedef enum caf_deregister_t + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY + } caf_deregister_t; + ++/** The opaque type to represent a coarray token. */ + typedef void *caf_token_t; +-/** Add a dummy type representing teams in coarrays. */ + ++/** The opaque type for teams. */ + typedef void *caf_team_t; + +-typedef struct caf_teams_list +-{ +- caf_team_t team; +- int team_id; +- struct caf_teams_list *prev; +-} caf_teams_list; +- +-typedef struct caf_used_teams_list +-{ +- struct caf_teams_list *team_list_elem; +- struct caf_used_teams_list *prev; +-} caf_used_teams_list; +- + /* When there is a vector subscript in this dimension, nvec == 0, otherwise, + lower_bound, upper_bound, stride contains the bounds relative to the declared + bounds; kind denotes the integer kind of the elements of vector[]. */ +@@ -238,8 +237,15 @@ bool PREFIX(is_contiguous)(gfc_descriptor_t *); + void PREFIX(init)(int *, char ***); + void PREFIX(finalize)(void); + ++#ifdef GCC_GE_16 ++int PREFIX(this_image)(caf_team_t); ++ ++int PREFIX(num_images)(caf_team_t, int32_t *); ++#else + int PREFIX(this_image)(int); ++ + int PREFIX(num_images)(int, int); ++#endif + + #ifdef GCC_GE_7 + void PREFIX(register)(size_t, caf_register_t, caf_token_t *, gfc_descriptor_t *, +@@ -359,11 +365,20 @@ void PREFIX(error_stop)(int QUIETARG) __attribute__((noreturn)); + + void PREFIX(fail_image)(void) __attribute__((noreturn)); + ++#ifdef GCC_GE_16 ++void PREFIX(form_team)(int, caf_team_t *, int *, int *, char *, charlen_t); ++void PREFIX(change_team)(caf_team_t, int *, char *, charlen_t); ++void PREFIX(end_team)(int *, char *, charlen_t); ++void PREFIX(sync_team)(caf_team_t, int *, char *, charlen_t); ++int PREFIX(team_number)(caf_team_t); ++caf_team_t PREFIX(get_team)(int32_t *); ++#else + void PREFIX(form_team)(int, caf_team_t *, int); + void PREFIX(change_team)(caf_team_t *, int); + void PREFIX(end_team)(caf_team_t *); + void PREFIX(sync_team)(caf_team_t *, int); + int PREFIX(team_number)(caf_team_t *); ++#endif + + int PREFIX(image_status)(int); + void PREFIX(failed_images)(gfc_descriptor_t *, int, int *); +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 8de5ad84d..98d2a3060 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -208,13 +208,17 @@ static win_sync *last_elem = NULL; + static win_sync *pending_puts = NULL; + #endif + ++#ifndef GCC_GE_16 + /* Linked list of static coarrays registered. Do not expose to public in the +- * header, because it is implementation specific. */ ++ * header, because it is implementation specific. ++ * ++ * From gcc-15 on, this list is contained in the teams handling. */ + struct caf_allocated_tokens_t + { + caf_token_t token; + struct caf_allocated_tokens_t *prev; + } *caf_allocated_tokens = NULL; ++#endif + + #ifdef GCC_GE_7 + /* Linked list of slave coarrays registered. */ +@@ -227,7 +231,7 @@ struct caf_allocated_slave_tokens_t + + /* Image status variable */ + static int img_status = 0; +-static MPI_Win *stat_tok; ++static MPI_Win stat_tok; + + /* Active messages variables */ + char **buff_am; +@@ -340,12 +344,59 @@ typedef struct gfc_max_dim_descriptor_t + + char err_buffer[MPI_MAX_ERROR_STRING]; + ++#ifdef GCC_GE_16 ++/* All CAF runtime calls should use this comm instead of MPI_COMM_WORLD for ++ * interoperability purposes. */ ++MPI_Comm *CAF_COMM_WORLD_store; ++#define CAF_COMM_WORLD (*CAF_COMM_WORLD_store) ++ ++typedef struct caf_teams_list ++{ ++ /* The communicator having all team members. */ ++ MPI_Comm communicator; ++ /* The unique id (over all other formed teams) of this team. */ ++ int team_id; ++ /* The id of this image in this team. */ ++ int image_id; ++ struct caf_teams_list *prev; ++} caf_teams_list_t; ++ ++typedef struct caf_team_stack_node ++{ ++ struct caf_teams_list *team_list_elem; ++ /* The list of tokens allocated in the current team. Needed to free them ++ * when the team is left. */ ++ struct allocated_tokens_t ++ { ++ mpi_caf_token_t *token; ++ struct allocated_tokens_t *next; ++ } *allocated_tokens; ++ struct caf_team_stack_node *parent; ++} caf_team_stack_node_t; ++ ++static caf_teams_list_t *teams_list = NULL; ++static caf_team_stack_node_t *current_team = NULL, *initial_team; ++#else + /* All CAF runtime calls should use this comm instead of MPI_COMM_WORLD for + * interoperability purposes. */ + MPI_Comm CAF_COMM_WORLD; + ++typedef struct caf_teams_list ++{ ++ caf_team_t team; ++ int team_id; ++ struct caf_teams_list *prev; ++} caf_teams_list; ++ ++typedef struct caf_used_teams_list ++{ ++ struct caf_teams_list *team_list_elem; ++ struct caf_used_teams_list *prev; ++} caf_used_teams_list; ++ + static caf_teams_list *teams_list = NULL; + static caf_used_teams_list *used_teams = NULL; ++#endif + + /* Emitted when a theorectically unreachable part is reached. */ + const char unreachable[] = "Fatal error: unreachable alternative found.\n"; +@@ -773,7 +824,7 @@ handle_is_present_message(ct_msg_t *msg, void *baseptr) + += sizeof_desc_for_rank(GFC_DESCRIPTOR_RANK((gfc_descriptor_t *)ptr)); + } + else +- ptr = baseptr; ++ ptr = &baseptr; + + accessor_hash_table[msg->accessor_index].u.is_present( + add_data, &msg->dest_image, &result, ptr, &src_token, 0); +@@ -1462,6 +1513,10 @@ PREFIX(init)(int *argc, char ***argv) + /* Flag rc as unused, because conditional compilation. */ + int ierr = 0, i = 0, j = 0, rc __attribute__((unused)), prov_lev = 0; + int is_init = 0, prior_thread_level = MPI_THREAD_MULTIPLE; ++#ifdef GCC_GE_16 ++ MPI_Comm tmp_world; ++#endif ++ + ierr = MPI_Initialized(&is_init); + chk_err(ierr); + +@@ -1507,7 +1562,12 @@ PREFIX(init)(int *argc, char ***argv) + + /* Duplicate MPI_COMM_WORLD so that no CAF internal functions use it. + * This is critical for MPI-interoperability. */ ++#ifdef GCC_GE_16 ++ rc = MPI_Comm_dup(MPI_COMM_WORLD, &tmp_world); ++ CAF_COMM_WORLD_store = &tmp_world; ++#else + rc = MPI_Comm_dup(MPI_COMM_WORLD, &CAF_COMM_WORLD); ++#endif + #ifdef WITH_FAILED_IMAGES + flag = (MPI_SUCCESS == rc); + rc = MPIX_Comm_agree(MPI_COMM_WORLD, &flag); +@@ -1548,8 +1608,16 @@ PREFIX(init)(int *argc, char ***argv) + sync_handles = malloc(caf_num_images * sizeof(MPI_Request)); + /* END SYNC IMAGE preparation. */ + +- stat_tok = malloc(sizeof(MPI_Win)); +- ++ /* BEGIN teams preparations. */ ++#ifdef GCC_GE_16 ++ teams_list = (caf_teams_list_t *)malloc(sizeof(caf_teams_list_t)); ++ *teams_list = (struct caf_teams_list){tmp_world, -1, caf_this_image, NULL}; ++ CAF_COMM_WORLD_store = &teams_list->communicator; ++ current_team ++ = (caf_team_stack_node_t *)malloc(sizeof(caf_team_stack_node_t)); ++ *current_team = (struct caf_team_stack_node){teams_list, NULL}; ++ initial_team = current_team; ++#else + teams_list = (caf_teams_list *)calloc(1, sizeof(caf_teams_list)); + teams_list->team_id = -1; + MPI_Comm *tmp_comm = (MPI_Comm *)calloc(1, sizeof(MPI_Comm)); +@@ -1559,6 +1627,8 @@ PREFIX(init)(int *argc, char ***argv) + used_teams = (caf_used_teams_list *)calloc(1, sizeof(caf_used_teams_list)); + used_teams->team_list_elem = teams_list; + used_teams->prev = NULL; ++#endif ++ /* END teams preparations. */ + + #ifdef WITH_FAILED_IMAGES + MPI_Comm_dup(MPI_COMM_WORLD, &alive_comm); +@@ -1592,12 +1662,12 @@ PREFIX(init)(int *argc, char ***argv) + + /* Setting img_status */ + ierr = MPI_Win_create(&img_status, sizeof(int), 1, mpi_info_same_size, +- CAF_COMM_WORLD, stat_tok); ++ CAF_COMM_WORLD, &stat_tok); + chk_err(ierr); +- CAF_Win_lock_all(*stat_tok); ++ CAF_Win_lock_all(stat_tok); + #else + ierr = MPI_Win_create(&img_status, sizeof(int), 1, MPI_INFO_NULL, +- CAF_COMM_WORLD, stat_tok); ++ CAF_COMM_WORLD, &stat_tok); + chk_err(ierr); + #endif // MPI_VERSION + +@@ -1645,7 +1715,7 @@ finalize_internal(int status_code) + chk_err(ierr); + #endif + /* For future security enclose setting img_status in a lock. */ +- CAF_Win_lock(MPI_LOCK_EXCLUSIVE, mpi_this_image, *stat_tok); ++ CAF_Win_lock(MPI_LOCK_EXCLUSIVE, mpi_this_image, stat_tok); + if (status_code == 0) + { + img_status = STAT_STOPPED_IMAGE; +@@ -1660,7 +1730,7 @@ finalize_internal(int status_code) + image_stati[mpi_this_image] = status_code; + #endif + } +- CAF_Win_unlock(mpi_this_image, *stat_tok); ++ CAF_Win_unlock(mpi_this_image, stat_tok); + + /* Announce to all other images, that this one has changed its execution + * status. */ +@@ -1739,6 +1809,43 @@ finalize_internal(int status_code) + #endif + + dprint("Freed all slave tokens.\n"); ++ ++#ifdef GCC_GE_16 ++ for (caf_team_stack_node_t *node = current_team; node;) ++ { ++ caf_team_stack_node_t *pn = node->parent; ++ MPI_Win *p; ++ ++ for (struct allocated_tokens_t *t = node->allocated_tokens; t;) ++ { ++ struct allocated_tokens_t *nt = t->next; ++ ++ p = TOKEN(t->token); ++ if (p != NULL) ++ CAF_Win_unlock_all(*p); ++ /* Unregister the window to the descriptors when freeing the token. */ ++ ierr = MPI_Win_free(p); ++ chk_err(ierr); ++ free(t->token); ++ free(t); ++ t = nt; ++ } ++ free(node); ++ node = pn; ++ } ++ current_team = initial_team = NULL; ++ ++ for (caf_teams_list_t *node = teams_list; node;) ++ { ++ caf_teams_list_t *pn = node->prev; ++ ++ if (node->team_id != -1) ++ MPI_Comm_free(&node->communicator); ++ ++ free(node); ++ node = pn; ++ } ++#else + struct caf_allocated_tokens_t *cur_tok = caf_allocated_tokens, + *prev = caf_allocated_tokens; + MPI_Win *p; +@@ -1762,6 +1869,7 @@ finalize_internal(int status_code) + free(cur_tok); + cur_tok = prev; + } ++#endif + #if MPI_VERSION >= 3 + ierr = MPI_Info_free(&mpi_info_same_size); + chk_err(ierr); +@@ -1815,7 +1923,7 @@ finalize_internal(int status_code) + MPI_Status status; + do + { +- ierr = MPI_Iprobe(MPI_ANY_SOURCE, MPI_ANY_TAG, CAF_COMM_WORLD, ++ ierr = MPI_Iprobe(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, + &probe_flag, &status); /* error is not of interest. */ + if (probe_flag) + { +@@ -1823,18 +1931,20 @@ finalize_internal(int status_code) + MPI_Get_count(&status, MPI_BYTE, &cnt); + void *buf = alloca(cnt); + ierr = MPI_Recv(buf, cnt, MPI_BYTE, status.MPI_SOURCE, status.MPI_TAG, +- CAF_COMM_WORLD, &status); ++ MPI_COMM_WORLD, &status); + chk_err(ierr); + } + } while (probe_flag); + } + #endif ++#ifndef GCC_GE_16 + dprint("freeing caf's communicator.\n"); + ierr = MPI_Comm_free(&CAF_COMM_WORLD); + chk_err(ierr); ++#endif + +- CAF_Win_unlock_all(*stat_tok); +- ierr = MPI_Win_free(stat_tok); ++ CAF_Win_unlock_all(stat_tok); ++ ierr = MPI_Win_free(&stat_tok); + chk_err(ierr); + + /* Only call Finalize if CAF runtime Initialized MPI. */ +@@ -1865,6 +1975,40 @@ PREFIX(finalize)(void) + finalize_internal(0); + } + ++#ifdef GCC_GE_16 ++int ++PREFIX(this_image)(caf_team_t team) ++{ ++ return team ? ((caf_teams_list_t *)team)->image_id : caf_this_image; ++} ++ ++int ++PREFIX(num_images)(caf_team_t team, int32_t *team_number) ++{ ++ if (team) ++ { ++ caf_teams_list_t *t = (caf_teams_list_t *)team; ++ int comm_size = 0, ierr; ++ ierr = MPI_Comm_size(t->communicator, &comm_size); ++ chk_err(ierr); ++ return comm_size; ++ } ++ if (team_number) ++ { ++ for (caf_teams_list_t *curr = teams_list; curr; curr = curr->prev) ++ if (curr->team_id == *team_number) ++ { ++ int comm_size = 0, ierr; ++ ierr = MPI_Comm_size(curr->communicator, &comm_size); ++ chk_err(ierr); ++ return comm_size; ++ } ++ ++ caf_runtime_error("NUM_IMAGES: Unknown team_number %d", *team_number); ++ } ++ return caf_num_images; ++} ++#else + /* TODO: This is interface is violating the F2015 standard, but not the gfortran + * API. Fix it (the fortran API). */ + int +@@ -1881,6 +2025,7 @@ PREFIX(num_images)(int distance __attribute__((unused)), + { + return caf_num_images; + } ++#endif + + #ifdef GCC_GE_7 + /* Register an object with the coarray library creating a token where +@@ -2031,11 +2176,19 @@ void PREFIX(register)(size_t size, caf_register_t type, caf_token_t *token, + free(init_array); + } + ++#ifdef GCC_GE_16 ++ struct allocated_tokens_t *allocated_token ++ = malloc(sizeof(struct allocated_tokens_t)); ++ allocated_token->next = current_team->allocated_tokens; ++ allocated_token->token = *token; ++ current_team->allocated_tokens = allocated_token; ++#else + struct caf_allocated_tokens_t *tmp + = malloc(sizeof(struct caf_allocated_tokens_t)); + tmp->prev = caf_allocated_tokens; + tmp->token = *token; + caf_allocated_tokens = tmp; ++#endif + + if (stat) + *stat = 0; +@@ -2220,6 +2373,40 @@ PREFIX(deregister)(caf_token_t *token, int *stat, char *errmsg, + #endif + } + #endif // GCC_GE_7 ++#ifdef GCC_GE_16 ++ { ++ struct allocated_tokens_t *cur = current_team->allocated_tokens, ++ *prev = current_team->allocated_tokens; ++ MPI_Win *p; ++ ++ while (cur) ++ { ++ if (cur->token == *token) ++ { ++ p = TOKEN(*token); ++#ifdef GCC_GE_7 ++ dprint("Found regular token %p for memptr_win: %d.\n", *token, ++ ((mpi_caf_token_t *)*token)->memptr_win); ++#endif ++ CAF_Win_unlock_all(*p); ++ ierr = MPI_Win_free(p); ++ chk_err(ierr); ++ ++ if (cur == current_team->allocated_tokens) ++ current_team->allocated_tokens = cur->next; ++ else ++ prev->next = cur->next; ++ ++ free(cur); ++ free(*token); ++ *token = NULL; ++ return; ++ } ++ prev = cur; ++ cur = cur->next; ++ } ++ } ++#else + { + struct caf_allocated_tokens_t *cur = caf_allocated_tokens, + *next = caf_allocated_tokens, *prev; +@@ -2247,12 +2434,14 @@ PREFIX(deregister)(caf_token_t *token, int *stat, char *errmsg, + + free(cur); + free(*token); ++ *token = NULL; + return; + } + next = cur; + cur = prev; + } + } ++#endif + + #ifdef GCC_GE_7 + /* Feel through: Has to be a component token. */ +@@ -2297,6 +2486,7 @@ PREFIX(deregister)(caf_token_t *token, int *stat, char *errmsg, + free(cur_stok); + ierr = MPI_Free_mem(*token); + chk_err(ierr); ++ *token = NULL; + return; + } + +@@ -5498,6 +5688,54 @@ get_from_self(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + } + } + ++bool ++team_translate(int *remote_image, int *this_image, caf_token_t token, ++ int image_index, caf_team_t *team, int *team_number, int *stat) ++{ ++ MPI_Group current_team_group, win_group; ++ int ierr; ++ int trans_ranks[2]; ++ MPI_Comm comm = CAF_COMM_WORLD; ++ ++#ifdef GCC_GE_16 ++ if (team) ++ comm = (*(caf_teams_list_t **)team)->communicator; ++ else if (team_number) ++ { ++ bool found = false; ++ for (caf_team_stack_node_t *cur = current_team; cur; cur = cur->parent) ++ if (cur->team_list_elem->team_id == *team_number) ++ { ++ comm = cur->team_list_elem->communicator; ++ found = true; ++ break; ++ } ++ if (!found) ++ { ++ caf_internal_error("Team number %d not found", stat, NULL, 0, ++ *team_number); ++ return false; ++ } ++ } ++#endif ++ ++ ierr = MPI_Comm_group(comm, ¤t_team_group); ++ chk_err(ierr); ++ ierr = MPI_Win_get_group(*TOKEN(token), &win_group); ++ chk_err(ierr); ++ ierr = MPI_Group_translate_ranks(current_team_group, 2, ++ (int[]){image_index - 1, mpi_this_image}, ++ win_group, trans_ranks); ++ chk_err(ierr); ++ *remote_image = trans_ranks[0]; ++ *this_image = trans_ranks[1]; ++ ierr = MPI_Group_free(¤t_team_group); ++ chk_err(ierr); ++ ierr = MPI_Group_free(&win_group); ++ chk_err(ierr); ++ return true; ++} ++ + /* Get data from a remote image's memory pointed to by `token`. The image is + * given by `image_index`. When the source is descriptor array, then + * `opt_src_desc` gives its dimension as of the source image. On the remote +@@ -5525,12 +5763,9 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc, + const bool may_realloc_dst, const int getter_index, + void *get_data, const size_t get_data_size, int *stat, +- caf_team_t *team __attribute__((unused)), +- int *team_number __attribute__((unused))) ++ caf_team_t *team, int *team_number) + { +- MPI_Group current_team_group, win_group; + int ierr, this_image, remote_image; +- int trans_ranks[2]; + bool free_t_buff, free_msg; + void *t_buff; + ct_msg_t *msg; +@@ -5553,20 +5788,9 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + // Get mapped remote image + if (external_call) + { +- ierr = MPI_Comm_group(CAF_COMM_WORLD, ¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Win_get_group(*TOKEN(token), &win_group); +- chk_err(ierr); +- ierr = MPI_Group_translate_ranks(current_team_group, 2, +- (int[]){image_index - 1, mpi_this_image}, +- win_group, trans_ranks); +- chk_err(ierr); +- remote_image = trans_ranks[0]; +- this_image = trans_ranks[1]; +- ierr = MPI_Group_free(¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Group_free(&win_group); +- chk_err(ierr); ++ if (unlikely(!team_translate(&remote_image, &this_image, token, image_index, ++ team, team_number, stat))) ++ return; + } + else + { +@@ -5757,10 +5981,10 @@ PREFIX(is_present_on_remote)(caf_token_t token, const int image_index, + + check_image_health(remote_image, stat); + +- dprint( +- "Entering is_present_on_remote(), token = %p, win_rank = %d, this_rank = " +- "%d, is_present index = %d, sizeof(msg) = %ld.\n", +- token, remote_image, this_image, is_present_index, msg_size); ++ dprint("Entering is_present_on_remote(), token = %p, memptr = %p, win_rank = " ++ "%d, this_rank = %d, is_present index = %d, sizeof(msg) = %ld.\n", ++ token, ((mpi_caf_token_t *)token)->memptr, remote_image, this_image, ++ is_present_index, msg_size); + + if (this_image == remote_image) + { +@@ -5770,7 +5994,7 @@ PREFIX(is_present_on_remote)(caf_token_t token, const int image_index, + + dprint("Shortcutting due to self access on image %d.\n", image_index); + accessor_hash_table[is_present_index].u.is_present( +- add_data, &this_image, &result, src_ptr, &src_token, 0); ++ add_data, &this_image, &result, &src_ptr, &src_token, 0); + + return result; + } +@@ -5915,13 +6139,10 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + size_t *opt_src_charlen, + const gfc_descriptor_t *opt_src_desc, + const int setter_index, void *add_data, +- const size_t add_data_size, int *stat, +- caf_team_t *team __attribute__((unused)), +- int *team_number __attribute__((unused))) ++ const size_t add_data_size, int *stat, caf_team_t *team, ++ int *team_number) + { +- MPI_Group current_team_group, win_group; + int ierr, this_image, remote_image; +- int trans_ranks[2]; + bool free_msg; + ct_msg_t *msg; + const bool dst_incl_desc = opt_dst_desc, has_src_desc = opt_src_desc, +@@ -5944,20 +6165,9 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + // Get mapped remote image + if (external_call) + { +- ierr = MPI_Comm_group(CAF_COMM_WORLD, ¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Win_get_group(*TOKEN(token), &win_group); +- chk_err(ierr); +- ierr = MPI_Group_translate_ranks(current_team_group, 2, +- (int[]){image_index - 1, mpi_this_image}, +- win_group, trans_ranks); +- chk_err(ierr); +- remote_image = trans_ranks[0]; +- this_image = trans_ranks[1]; +- ierr = MPI_Group_free(¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Group_free(&win_group); +- chk_err(ierr); ++ if (unlikely(!team_translate(&remote_image, &this_image, token, image_index, ++ team, team_number, stat))) ++ return; + } + else + { +@@ -6106,10 +6316,8 @@ PREFIX(transfer_between_remotes)( + const int src_image_index, const int src_access_index, void *src_add_data, + const size_t src_add_data_size, const size_t in_src_size, + const bool scalar_transfer, int *dst_stat, int *src_stat, +- caf_team_t *dst_team __attribute__((unused)), +- int *dst_team_number __attribute__((unused)), +- caf_team_t *src_team __attribute__((unused)), +- int *src_team_number __attribute__((unused))) ++ caf_team_t *dst_team, int *dst_team_number, caf_team_t *src_team, ++ int *src_team_number) + { + MPI_Group current_team_group, win_group; + int ierr, this_image, src_remote_image, dst_remote_image; +@@ -6138,22 +6346,14 @@ PREFIX(transfer_between_remotes)( + *src_stat = 0; + + // Get mapped remote image +- ierr = MPI_Comm_group(CAF_COMM_WORLD, ¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Win_get_group(*TOKEN(src_token), &win_group); +- chk_err(ierr); +- ierr = MPI_Group_translate_ranks( +- current_team_group, 3, +- (int[]){src_image_index - 1, dst_image_index - 1, mpi_this_image}, +- win_group, trans_ranks); +- chk_err(ierr); +- src_remote_image = trans_ranks[0]; +- dst_remote_image = trans_ranks[1]; +- this_image = trans_ranks[2]; +- ierr = MPI_Group_free(¤t_team_group); +- chk_err(ierr); +- ierr = MPI_Group_free(&win_group); +- chk_err(ierr); ++ if (unlikely(!team_translate(&src_remote_image, &this_image, src_token, ++ src_image_index, src_team, src_team_number, ++ src_stat))) ++ return; ++ if (unlikely(!team_translate(&dst_remote_image, &this_image, dst_token, ++ dst_image_index, dst_team, dst_team_number, ++ dst_stat))) ++ return; + + dprint("team-map: dst(in) %d -> %d, src(in) %d -> %d, this %d -> %d.\n", + dst_image_index, dst_remote_image, src_image_index, src_remote_image, +@@ -10152,6 +10352,55 @@ unsupported_fail_images_message(const char *functionname) + #endif + } + ++#ifdef GCC_GE_16 ++void ++PREFIX(form_team)(int team_id, caf_team_t *team, int *new_index, int *stat, ++ char *errmsg, charlen_t errmsg_len) ++{ ++ static const char *duplicate_team_id ++ = "FORM TEAM: Team ids have to be unique"; ++ static const char *negative_team_id ++ = "FORM TEAM: Team id shall be a positive unique integer"; ++ static const char *negative_new_index ++ = "FORM TEAM: NEW_INDEX= shall be a positive unique integer"; ++ caf_teams_list_t *new_team; ++ MPI_Comm current_comm = CAF_COMM_WORLD; ++ int ierr; ++ int key = new_index ? *new_index : caf_this_image; ++ ++ if (stat) ++ *stat = 0; ++ ++ for (caf_teams_list_t *cur = teams_list; cur; cur = cur->prev) ++ if (cur->team_id == team_id) ++ { ++ caf_internal_error(duplicate_team_id, stat, errmsg, errmsg_len); ++ return; ++ } ++ if (team_id < 0) ++ { ++ caf_internal_error(negative_team_id, stat, errmsg, errmsg_len); ++ return; ++ } ++ if (new_index && *new_index < 0) ++ { ++ caf_internal_error(negative_new_index, stat, errmsg, errmsg_len); ++ return; ++ } ++ ++ new_team = (caf_teams_list_t *)malloc(sizeof(struct caf_teams_list)); ++ new_team->team_id = team_id; ++ new_team->image_id = key; ++ new_team->prev = teams_list; ++ ++ ierr ++ = MPI_Comm_split(current_comm, team_id, key - 1, &new_team->communicator); ++ chk_err(ierr); ++ ++ teams_list = new_team; ++ *team = new_team; ++} ++#else + void + PREFIX(form_team)(int team_id, caf_team_t *team, + int index __attribute__((unused))) +@@ -10172,7 +10421,43 @@ PREFIX(form_team)(int team_id, caf_team_t *team, + teams_list->team = newcomm; + *team = tmp; + } ++#endif + ++#ifdef GCC_GE_16 ++void ++PREFIX(change_team)(caf_team_t team, int *stat, char *errmsg, ++ charlen_t errmsg_len) ++{ ++ caf_team_stack_node_t *new_current_team = NULL; ++ caf_teams_list_t *provisioned_team = (caf_teams_list_t *)team; ++ int ierr; ++ ++ if (stat) ++ *stat = 0; ++ ++ if (provisioned_team == NULL) ++ { ++ caf_internal_error("CHANGE TEAM: Called on a non-existing team", stat, ++ errmsg, errmsg_len); ++ return; ++ } ++ ++ new_current_team ++ = (caf_team_stack_node_t *)malloc(sizeof(caf_team_stack_node_t)); ++ *new_current_team ++ = (caf_team_stack_node_t){provisioned_team, NULL, current_team}; ++ ++ current_team = new_current_team; ++ CAF_COMM_WORLD_store = ¤t_team->team_list_elem->communicator; ++ ierr = MPI_Comm_rank(CAF_COMM_WORLD, &mpi_this_image); ++ chk_err(ierr); ++ caf_this_image = mpi_this_image + 1; ++ ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); ++ chk_err(ierr); ++ ierr = MPI_Barrier(CAF_COMM_WORLD); ++ chk_err(ierr); ++} ++#else + void + PREFIX(change_team)(caf_team_t *team, int coselector __attribute__((unused))) + { +@@ -10196,13 +10481,13 @@ PREFIX(change_team)(caf_team_t *team, int coselector __attribute__((unused))) + /* + tmp_list = teams_list; + +- while (tmp_list) +- { +- if (tmp_list->team == tmp_team) +- break; +- tmp_list = tmp_list->prev; +- } +- */ ++ while (tmp_list) ++ { ++ if (tmp_list->team == tmp_team) ++ break; ++ tmp_list = tmp_list->prev; ++ } ++ */ + + if (tmp_list == NULL) + caf_runtime_error("CHANGE TEAM called on a non-existing team"); +@@ -10220,7 +10505,49 @@ PREFIX(change_team)(caf_team_t *team, int coselector __attribute__((unused))) + ierr = MPI_Barrier(*tmp_comm); + chk_err(ierr); + } ++#endif + ++#ifdef GCC_GE_16 ++MPI_Fint ++PREFIX(get_communicator)(caf_team_t *team) ++{ ++ caf_teams_list_t *cur_team = team ? *team : current_team->team_list_elem; ++ ++ MPI_Fint ret = MPI_Comm_c2f(cur_team->communicator); ++ ++ return ret; ++} ++ ++int ++PREFIX(team_number)(caf_team_t team) ++{ ++ if (team != NULL) ++ return ((caf_teams_list_t *)team)->team_id; ++ else ++ return current_team->team_list_elem->team_id; /* current team */ ++} ++ ++caf_team_t ++PREFIX(get_team)(int32_t *level) ++{ ++ if (!level) ++ return current_team->team_list_elem; ++ ++ switch ((caf_team_level_t)*level) ++ { ++ case CAF_INITIAL_TEAM: ++ return initial_team->team_list_elem; ++ case CAF_PARENT_TEAM: ++ return current_team->parent ? current_team->parent->team_list_elem ++ : initial_team->team_list_elem; ++ case CAF_CURRENT_TEAM: ++ return current_team->team_list_elem; ++ default: ++ caf_runtime_error("Illegal value for GET_TEAM"); ++ } ++ return NULL; /* To prevent any warnings. */ ++} ++#else + MPI_Fint + PREFIX(get_communicator)(caf_team_t *team) + { +@@ -10232,7 +10559,6 @@ PREFIX(get_communicator)(caf_team_t *team) + MPI_Fint ret = MPI_Comm_c2f(*comm_ptr); + + return ret; +- // return *(int*)comm_ptr; + } + + int +@@ -10243,7 +10569,48 @@ PREFIX(team_number)(caf_team_t *team) + else + return used_teams->team_list_elem->team_id; /* current team */ + } ++#endif ++ ++#ifdef GCC_GE_16 ++void ++PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) ++{ ++ caf_team_stack_node_t *ending_team = current_team; ++ int ierr; ++ ++ if (stat) ++ *stat = 0; ++ ++ ierr = MPI_Barrier(CAF_COMM_WORLD); ++ chk_err(ierr); ++ if (current_team->parent == NULL) ++ { ++ caf_internal_error("END TEAM called on initial team", stat, errmsg, ++ errmsg_len); ++ return; ++ } + ++ for (struct allocated_tokens_t *ac = current_team->allocated_tokens; ac;) ++ { ++ struct allocated_tokens_t *nac = ac->next; ++ ++ PREFIX(deregister)((void **)&ac->token, ++ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, errmsg, ++ errmsg_len); ++ free(ac); ++ ac = nac; ++ } ++ current_team = current_team->parent; ++ ++ CAF_COMM_WORLD_store = ¤t_team->team_list_elem->communicator; ++ ierr = MPI_Comm_rank(CAF_COMM_WORLD, &mpi_this_image); ++ chk_err(ierr); ++ caf_this_image = mpi_this_image + 1; ++ ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); ++ chk_err(ierr); ++ free(ending_team); ++} ++#else + void + PREFIX(end_team)(caf_team_t *team __attribute__((unused))) + { +@@ -10271,7 +10638,40 @@ PREFIX(end_team)(caf_team_t *team __attribute__((unused))) + ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); + chk_err(ierr); + } ++#endif + ++#ifdef GCC_GE_16 ++void ++PREFIX(sync_team)(caf_team_t team, int *stat, char *errmsg, ++ charlen_t errmsg_len) ++{ ++ caf_teams_list_t *team_to_sync = (caf_teams_list_t *)team; ++ caf_team_stack_node_t *active_team = 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->prev != active_team->team_list_elem) ++ /* if the team is not a child */ ++ for (; active_team && active_team->team_list_elem != team_to_sync; ++ active_team = active_team->parent) ++ ; ++ ++ if (!active_team) ++ { ++ caf_internal_error("SYNC TEAM: Called on team different from current, " ++ "or ancestor, or child", ++ stat, errmsg, errmsg_len); ++ return; ++ } ++ ++ int ierr = MPI_Barrier(team_to_sync->communicator); ++ chk_err(ierr); ++} ++#else + void + PREFIX(sync_team)(caf_team_t *team, int unused __attribute__((unused))) + { +@@ -10303,6 +10703,7 @@ PREFIX(sync_team)(caf_team_t *team, int unused __attribute__((unused))) + int ierr = MPI_Barrier(*tmp_comm); + chk_err(ierr); + } ++#endif + + extern void + _gfortran_random_seed_i4(int32_t *size, gfc_dim1_descriptor_t *put, +diff --git a/src/tests/unit/teams/CMakeLists.txt b/src/tests/unit/teams/CMakeLists.txt +index 2b72d8d35..e5d5eb9db 100644 +--- a/src/tests/unit/teams/CMakeLists.txt ++++ b/src/tests/unit/teams/CMakeLists.txt +@@ -1,4 +1,4 @@ +-caf_compile_executable(team_number team-number.f90) ++caf_compile_executable(team_number_pre15 team_number_pre15.f90) + caf_compile_executable(teams_subset teams_subset.f90) + caf_compile_executable(get_communicator get-communicator.F90) + caf_compile_executable(teams_coarray_get teams_coarray_get.f90) +@@ -7,3 +7,8 @@ caf_compile_executable(teams_coarray_send teams_coarray_send.f90) + caf_compile_executable(teams_coarray_send_by_ref teams_coarray_send.f90) + caf_compile_executable(teams_coarray_sendget teams_coarray_sendget.f90) + caf_compile_executable(sync_team sync-team.f90) ++if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0.0)) ++ caf_compile_executable(team_number team_number.f90) ++ caf_compile_executable(teams_this_image teams_this_image.f90) ++ caf_compile_executable(teams_num_images teams_num_images.f90) ++endif() +diff --git a/src/tests/unit/teams/team_number.f90 b/src/tests/unit/teams/team_number.f90 +new file mode 100644 +index 000000000..e34b339d2 +--- /dev/null ++++ b/src/tests/unit/teams/team_number.f90 +@@ -0,0 +1,68 @@ ++! BSD 3-Clause License ++! ++! Copyright (c) 2018-2019, Sourcery Institute ++! All rights reserved. ++! ++! Redistribution and use in source and binary forms, with or without ++! modification, are permitted provided that the following conditions are met: ++! ++! * Redistributions of source code must retain the above copyright notice, this ++! list of conditions and the following disclaimer. ++! ++! * Redistributions in binary form must reproduce the above copyright notice, ++! this list of conditions and the following disclaimer in the documentation ++! and/or other materials provided with the distribution. ++! ++! * Neither the name of the copyright holder nor the names of its ++! contributors may be used to endorse or promote products derived from ++! this software without specific prior written permission. ++! ++! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ++! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE ++! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ++! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ++! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ++! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ++! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++program main ++ !! summary: Test team_number intrinsic function ++ use iso_fortran_env, only : team_type, current_team ++ use iso_c_binding, only : c_loc ++ use oc_assertions_interface, only : assert ++ ++ implicit none ++ ++ integer, parameter :: standard_initial_value=-1 ++ ++ type(team_type) :: parent, child ++ ++ if (num_images() < 8) error stop "I need at least 8 images to function." ++ ++ call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") ++ ++ call assert(team_number(get_team(current_team))==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") ++ ++ after_change_team: block ++ associate(parent_team_number => 100 + (num_images()-1)/4, child_team_number => 1000 + mod(num_images()-1,4)/2) ++ !! Prepare for forming two teams: my_team = 1 for even image numbers in the initial team; 2 for odd image numbers ++ form team(parent_team_number,parent) ++ change team(parent) ++ call assert(team_number()==parent_team_number,"team number conforms with Fortran standard after 'change team'") ++ form team (child_team_number, child) ++ change team(child) ++ call assert(team_number()==child_team_number,"team number conforms with Fortran standard after 'change team'") ++ call assert(team_number(child)==child_team_number,"team_number(child) conforms with Fortran standard after 'change team'") ++ call assert(team_number(parent)==parent_team_number,"team_number(parent) conforms with Fortran standard") ++ end team ++ end team ++ call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard") ++ end associate ++ end block after_change_team ++ ++ sync all ++ if (this_image()==1) print *,"Test passed." ++ ++end program +diff --git a/src/tests/unit/teams/team-number.f90 b/src/tests/unit/teams/team_number_pre15.f90 +similarity index 100% +rename from src/tests/unit/teams/team-number.f90 +rename to src/tests/unit/teams/team_number_pre15.f90 +diff --git a/src/tests/unit/teams/teams_num_images.f90 b/src/tests/unit/teams/teams_num_images.f90 +new file mode 100644 +index 000000000..b90a9105f +--- /dev/null ++++ b/src/tests/unit/teams/teams_num_images.f90 +@@ -0,0 +1,52 @@ ++! BSD 3-Clause License ++! ++! Copyright (c) 2018-2025, Sourcery Institute ++! All rights reserved. ++! ++! Redistribution and use in source and binary forms, with or without ++! modification, are permitted provided that the following conditions are met: ++! ++! * Redistributions of source code must retain the above copyright notice, this ++! list of conditions and the following disclaimer. ++! ++! * Redistributions in binary form must reproduce the above copyright notice, ++! this list of conditions and the following disclaimer in the documentation ++! and/or other materials provided with the distribution. ++! ++! * Neither the name of the copyright holder nor the names of its ++! contributors may be used to endorse or promote products derived from ++! this software without specific prior written permission. ++! ++! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ++! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE ++! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ++! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ++! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ++! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ++! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++use, intrinsic :: iso_fortran_env, only: team_type ++ ++type(team_type) :: team ++ ++associate(me => this_image(), num => num_images()) ++ sync all ++ form team(MOD(me, 2) + 1, team) ++ ++ j1 = num_images() ++ if (j1 /= num) stop 1 ++ ++ j2 = num_images(team) ++ if (j2 /= num / 2) stop 2 ++ ++ j3 = num_images(MOD(me, 2) + 1) ++ if (j3 /= num / 2) stop 3 ++ ++ sync all ++ ++ if (me == 1) print *,"Test passed." ++end associate ++ ++end +diff --git a/src/tests/unit/teams/teams_this_image.f90 b/src/tests/unit/teams/teams_this_image.f90 +new file mode 100644 +index 000000000..4f683f1d1 +--- /dev/null ++++ b/src/tests/unit/teams/teams_this_image.f90 +@@ -0,0 +1,108 @@ ++! BSD 3-Clause License ++! ++! Copyright (c) 2018-2025, Sourcery Institute ++! All rights reserved. ++! ++! Redistribution and use in source and binary forms, with or without ++! modification, are permitted provided that the following conditions are met: ++! ++! * Redistributions of source code must retain the above copyright notice, this ++! list of conditions and the following disclaimer. ++! ++! * Redistributions in binary form must reproduce the above copyright notice, ++! this list of conditions and the following disclaimer in the documentation ++! and/or other materials provided with the distribution. ++! ++! * Neither the name of the copyright holder nor the names of its ++! contributors may be used to endorse or promote products derived from ++! this software without specific prior written permission. ++! ++! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ++! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE ++! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ++! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ++! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ++! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ++! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++use, intrinsic :: iso_fortran_env, only: team_type ++ ++integer :: caf(2,2)[3,*], sub(2) ++integer, allocatable :: res(:) ++type(team_type) :: team ++ ++form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1) ++ ++associate(me => this_image(), num => num_images()) ++ associate(n_ind => MOD(me + 43, num) + 1) ++ ++ j1 = this_image() ++ if (j1 /= me) stop 1 ++ ++ sub = c_t_i(lcobound(caf), ucobound(caf), me) ++ res = this_image(caf) ++ if (any (res /= sub)) stop 2 ++ ++ j2 = this_image(caf, 1) ++ if (j2 /= sub(1)) stop 3 ++ ++ j3 = this_image(team) ++ if (j3 /= n_ind) stop 4 ++ ++ sub = c_t_i(lcobound(caf), ucobound(caf), n_ind) ++ res = this_image(caf, team) ++ if (any(res /= sub)) stop 5 ++ ++ j4 = this_image(caf, 1, team) ++ if (j4 /= sub(1)) stop 6 ++ ++ change team(team) ++ j5 = this_image() ++ if (j5 /= n_ind) stop 11 ++ ++ sub = c_t_i(lcobound(caf), ucobound(caf), n_ind) ++ res = this_image(caf) ++ if (any (res /= sub)) stop 12 ++ ++ j6 = this_image(caf, 1) ++ if (j6 /= sub(1)) stop 13 ++ ++ j7 = this_image(team) ++ if (j7 /= n_ind) stop 14 ++ ++ sub = c_t_i(lcobound(caf), ucobound(caf), n_ind) ++ res = this_image(caf, team) ++ if (any(res /= sub)) stop 15 ++ ++ j8 = this_image(caf, 1, team) ++ if (j8 /= sub(1)) stop 16 ++ ++ end team ++ sync all ++ ++ if (me == 1) print *,"Test passed." ++ end associate ++end associate ++ ++contains ++ ++function c_t_i(lco, uco, me) result(sub) ++ integer, intent(in) :: lco(:), uco(:) ++ integer, intent(in) :: me ++ integer :: i, n, m, ml, extend ++ integer :: sub(size(lco)) ++ ++ n = size(lco) ++ m = me - 1 ++ do i = 1, n - 1 ++ extend = uco(i) - lco(i) + 1 ++ ml = m ++ m = m / extend ++ sub(i) = ml - m * extend + lco(i) ++ end do ++ sub(n) = m + lco(n) ++ ++end function ++end diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_02_Fix_team_number.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_02_Fix_team_number.patch new file mode 100644 index 0000000000..8357195e16 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_02_Fix_team_number.patch @@ -0,0 +1,159 @@ +From 9a82ef47e7d0d19fdc493506cb7197b4901f2070 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Mon, 28 Apr 2025 09:00:46 +0200 +Subject: [PATCH] Fix team_number test. + +--- + CMakeLists.txt | 4 +- + src/tests/unit/teams/CMakeLists.txt | 3 +- + .../{team_number.f90 => team_number.F90} | 4 +- + src/tests/unit/teams/team_number_pre15.f90 | 71 ------------------- + 4 files changed, 5 insertions(+), 77 deletions(-) + rename src/tests/unit/teams/{team_number.f90 => team_number.F90} (98%) + delete mode 100644 src/tests/unit/teams/team_number_pre15.f90 + +diff --git a/CMakeLists.txt b/CMakeLists.txt +index 888613454..8f9ee35ae 100644 +--- a/CMakeLists.txt ++++ b/CMakeLists.txt +@@ -806,6 +806,7 @@ if(opencoarrays_aware_compiler) + add_caf_test(comp_allocated_2 2 comp_allocated_2) + add_caf_test(alloc_comp_get_convert_nums 2 alloc_comp_get_convert_nums) + if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8) ++ add_caf_test(team_number 8 team_number) + add_caf_test(teams_subset 3 teams_subset) + add_caf_test(get_communicator 3 get_communicator) + add_caf_test(teams_coarray_get 5 teams_coarray_get) +@@ -818,11 +819,8 @@ if(opencoarrays_aware_compiler) + set_tests_properties(alloc_comp_multidim_shape PROPERTIES TIMEOUT 300) + endif() + if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 15) +- add_caf_test(team_number 8 team_number) + add_caf_test(teams_this_image 8 teams_this_image) + add_caf_test(teams_num_images 8 teams_num_images) +- else() +- add_caf_test(team_number_pre15 8 team_number_pre15) + endif() + endif() + +diff --git a/src/tests/unit/teams/CMakeLists.txt b/src/tests/unit/teams/CMakeLists.txt +index e5d5eb9db..8307b0788 100644 +--- a/src/tests/unit/teams/CMakeLists.txt ++++ b/src/tests/unit/teams/CMakeLists.txt +@@ -1,4 +1,4 @@ +-caf_compile_executable(team_number_pre15 team_number_pre15.f90) ++caf_compile_executable(team_number team_number.F90) + caf_compile_executable(teams_subset teams_subset.f90) + caf_compile_executable(get_communicator get-communicator.F90) + caf_compile_executable(teams_coarray_get teams_coarray_get.f90) +@@ -8,7 +8,6 @@ caf_compile_executable(teams_coarray_send_by_ref teams_coarray_send.f90) + caf_compile_executable(teams_coarray_sendget teams_coarray_sendget.f90) + caf_compile_executable(sync_team sync-team.f90) + if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0.0)) +- caf_compile_executable(team_number team_number.f90) + caf_compile_executable(teams_this_image teams_this_image.f90) + caf_compile_executable(teams_num_images teams_num_images.f90) + endif() +diff --git a/src/tests/unit/teams/team_number.f90 b/src/tests/unit/teams/team_number.F90 +similarity index 98% +rename from src/tests/unit/teams/team_number.f90 +rename to src/tests/unit/teams/team_number.F90 +index e34b339d2..a50ebd676 100644 +--- a/src/tests/unit/teams/team_number.f90 ++++ b/src/tests/unit/teams/team_number.F90 +@@ -29,7 +29,7 @@ + ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + program main + !! summary: Test team_number intrinsic function +- use iso_fortran_env, only : team_type, current_team ++ use, intrinsic :: iso_fortran_env + use iso_c_binding, only : c_loc + use oc_assertions_interface, only : assert + +@@ -43,7 +43,9 @@ program main + + call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") + ++#ifdef GCC_GE_15 + call assert(team_number(get_team(current_team))==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") ++#endif + + after_change_team: block + associate(parent_team_number => 100 + (num_images()-1)/4, child_team_number => 1000 + mod(num_images()-1,4)/2) +diff --git a/src/tests/unit/teams/team_number_pre15.f90 b/src/tests/unit/teams/team_number_pre15.f90 +deleted file mode 100644 +index 7cc1a8758..000000000 +--- a/src/tests/unit/teams/team_number_pre15.f90 ++++ /dev/null +@@ -1,71 +0,0 @@ +-! BSD 3-Clause License +-! +-! Copyright (c) 2018-2019, Sourcery Institute +-! All rights reserved. +-! +-! Redistribution and use in source and binary forms, with or without +-! modification, are permitted provided that the following conditions are met: +-! +-! * Redistributions of source code must retain the above copyright notice, this +-! list of conditions and the following disclaimer. +-! +-! * Redistributions in binary form must reproduce the above copyright notice, +-! this list of conditions and the following disclaimer in the documentation +-! and/or other materials provided with the distribution. +-! +-! * Neither the name of the copyright holder nor the names of its +-! contributors may be used to endorse or promote products derived from +-! this software without specific prior written permission. +-! +-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +-! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +-! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +-! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-program main +- !! summary: Test team_number intrinsic function +- use iso_fortran_env, only : team_type +- use iso_c_binding, only : c_loc +- use oc_assertions_interface, only : assert +- +- implicit none +- +- integer, parameter :: standard_initial_value=-1 +- +- type(team_type) :: parent, child +- +- if (num_images() < 8) error stop "I need at least 8 images to function." +- +- call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") +- +- !call assert( +- ! team_number(c_loc(home))==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'" +- !) +- !! TODO: uncomment the above assertion after implementing support for team_number's optional argument: +- +- after_change_team: block +- associate(parent_team_number => 100 + (num_images()-1)/4, child_team_number => 1000 + mod(num_images()-1,4)/2) +- !! Prepare for forming two teams: my_team = 1 for even image numbers in the initial team; 2 for odd image numbers +- form team(parent_team_number,parent) +- change team(parent) +- call assert(team_number()==parent_team_number,"team number conforms with Fortran standard after 'change team'") +- form team (child_team_number, child) +- change team(child) +- call assert(team_number()==child_team_number,"team number conforms with Fortran standard after 'change team'") +- call assert(team_number(child)==child_team_number,"team_number(child) conforms with Fortran standard after 'change team'") +- call assert(team_number(parent)==parent_team_number,"team_number(parent) conforms with Fortran standard") +- end team +- end team +- call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard") +- end associate +- end block after_change_team +- +- sync all +- if (this_image()==1) print *,"Test passed." +- +-end program diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_03_Remove_wrong_error.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_03_Remove_wrong_error.patch new file mode 100644 index 0000000000..3cd9127147 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_03_Remove_wrong_error.patch @@ -0,0 +1,36 @@ +From c49237b2319016bfbd0acdf50de607339005c378 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Mon, 14 Apr 2025 10:54:16 +0200 +Subject: [PATCH] Remove wrong error. + +Issuing this error was a misinterpretation of the standard. +--- + src/runtime-libraries/mpi/mpi_caf.c | 8 -------- + 1 file changed, 8 deletions(-) + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 98d2a306..39dadf7d 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -10357,8 +10357,6 @@ void + PREFIX(form_team)(int team_id, caf_team_t *team, int *new_index, int *stat, + char *errmsg, charlen_t errmsg_len) + { +- static const char *duplicate_team_id +- = "FORM TEAM: Team ids have to be unique"; + static const char *negative_team_id + = "FORM TEAM: Team id shall be a positive unique integer"; + static const char *negative_new_index +@@ -10371,12 +10369,6 @@ PREFIX(form_team)(int team_id, caf_team_t *team, int *new_index, int *stat, + if (stat) + *stat = 0; + +- for (caf_teams_list_t *cur = teams_list; cur; cur = cur->prev) +- if (cur->team_id == team_id) +- { +- caf_internal_error(duplicate_team_id, stat, errmsg, errmsg_len); +- return; +- } + if (team_id < 0) + { + caf_internal_error(negative_team_id, stat, errmsg, errmsg_len); diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_04_Enchance_debug_logging.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_04_Enchance_debug_logging.patch new file mode 100644 index 0000000000..19886e3565 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_04_Enchance_debug_logging.patch @@ -0,0 +1,100 @@ +From e24b96abe083753dc5595ea5a1b4b26e6104280c Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Wed, 16 Apr 2025 13:38:57 +0200 +Subject: [PATCH] Enhance debug logging. + +--- + src/runtime-libraries/mpi/mpi_caf.c | 30 +++++++++++++++++++++++------ + 1 file changed, 24 insertions(+), 6 deletions(-) + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 39dadf7d..90b5c952 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -69,10 +69,19 @@ static char *caf_ref_type_str[] = { + #define dprint(...) + #define chk_err(...) + #else ++#ifdef GCC_GE_16 ++#define dprint(format, ...) \ ++ fprintf(stderr, "%d/%d (t(%d):%d/%d): %s(%d) " format, \ ++ global_this_image + 1, global_num_images, \ ++ current_team ? current_team->team_list_elem->team_id : -99, \ ++ caf_this_image, caf_num_images, __FUNCTION__, __LINE__, \ ++ ##__VA_ARGS__) ++#else + #define dprint(format, ...) \ +- fprintf(stderr, "%d/%d (t:%d/%d): %s(%d) " format, global_this_image + 1, \ ++ fprintf(stderr, "%d/%d (%d/%d): %s(%d) " format, global_this_image + 1, \ + global_num_images, caf_this_image, caf_num_images, __FUNCTION__, \ + __LINE__, ##__VA_ARGS__) ++#endif + #define chk_err(ierr) \ + do \ + { \ +@@ -2384,13 +2393,11 @@ PREFIX(deregister)(caf_token_t *token, int *stat, char *errmsg, + if (cur->token == *token) + { + p = TOKEN(*token); +-#ifdef GCC_GE_7 +- dprint("Found regular token %p for memptr_win: %d.\n", *token, +- ((mpi_caf_token_t *)*token)->memptr_win); +-#endif ++ dprint("Found regular token %p for memptr_win: %d.\n", *token, *p); + CAF_Win_unlock_all(*p); + ierr = MPI_Win_free(p); + chk_err(ierr); ++ dprint("Window destroyed.\n"); + + if (cur == current_team->allocated_tokens) + current_team->allocated_tokens = cur->next; +@@ -2536,7 +2543,13 @@ PREFIX(sync_all)(int *stat, char *errmsg, charlen_t errmsg_len) + ierr = MPI_Barrier(CAF_COMM_WORLD); + chk_err(ierr); + #endif +- dprint("MPI_Barrier = %d.\n", err); ++ dprint("Sync all on team %d, MPI_Barrier = %d.\n", ++#ifdef GCC_GE_16 ++ current_team->team_list_elem->team_id, ++#else ++ -1, ++#endif ++ err); + if (ierr == STAT_FAILED_IMAGE) + err = STAT_FAILED_IMAGE; + else if (ierr != 0) +@@ -10448,6 +10461,7 @@ PREFIX(change_team)(caf_team_t team, int *stat, char *errmsg, + chk_err(ierr); + ierr = MPI_Barrier(CAF_COMM_WORLD); + chk_err(ierr); ++ dprint("changed to team %d.\n", current_team->team_list_elem->team_id); + } + #else + void +@@ -10582,6 +10596,7 @@ PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) + return; + } + ++ dprint("ending team %d.\n", ending_team->team_list_elem->team_id); + for (struct allocated_tokens_t *ac = current_team->allocated_tokens; ac;) + { + struct allocated_tokens_t *nac = ac->next; +@@ -10601,6 +10616,7 @@ PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) + ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); + chk_err(ierr); + free(ending_team); ++ dprint("switched to team %d.\n", current_team->team_list_elem->team_id); + } + #else + void +@@ -10660,8 +10676,10 @@ PREFIX(sync_team)(caf_team_t team, int *stat, char *errmsg, + return; + } + ++ dprint("syncing team %d.\n", current_team->team_list_elem->team_id); + int ierr = MPI_Barrier(team_to_sync->communicator); + chk_err(ierr); ++ dprint("synced team %d.\n", current_team->team_list_elem->team_id); + } + #else + void diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_05_Add_owning_memory_flag.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_05_Add_owning_memory_flag.patch new file mode 100644 index 0000000000..da3f2aab9d --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_05_Add_owning_memory_flag.patch @@ -0,0 +1,115 @@ +From 2431ff99e0dcd01ae98e598a7c96d26b62b7bc41 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Wed, 16 Apr 2025 13:41:56 +0200 +Subject: [PATCH] Add owning memory flag. + +--- + src/application-binary-interface/libcaf.h | 5 +- + src/runtime-libraries/mpi/mpi_caf.c | 57 +++++++++++++++++++++-- + 2 files changed, 58 insertions(+), 4 deletions(-) + +diff --git a/src/application-binary-interface/libcaf.h b/src/application-binary-interface/libcaf.h +index 66a93767..bd22d5eb 100644 +--- a/src/application-binary-interface/libcaf.h ++++ b/src/application-binary-interface/libcaf.h +@@ -88,7 +88,10 @@ typedef enum caf_register_t + CAF_REGTYPE_EVENT_STATIC, + CAF_REGTYPE_EVENT_ALLOC, + CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY, +- CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY ++ CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY, ++#ifdef GCC_GE_16 ++ CAF_REGTYPE_COARRAY_MAP_EXISTING, ++#endif + } caf_register_t; + + /* Describes the action to take on _caf_deregister. Keep in sync with +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 90b5c952..1d6075b5 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -121,6 +121,11 @@ typedef struct mpi_caf_token_t + /* The pointer to the primary array, i.e., to coarrays that are arrays and + * not a derived type. */ + gfc_descriptor_t *desc; ++#ifdef GCC_GE_16 ++ /* Only set to false, when this token maps memory into another token's ++ * memory segment. This only happens when in an associate or a change team. */ ++ int owning_memory; ++#endif + } mpi_caf_token_t; + + /* For components of derived type coarrays a slave_token is needed when the +@@ -2147,6 +2152,38 @@ void PREFIX(register)(size_t size, caf_register_t type, caf_token_t *token, + slave_token, slave_token->memptr, slave_token->desc); + } + break; ++#ifdef GCC_GE_16 ++ case CAF_REGTYPE_COARRAY_MAP_EXISTING: ++ { ++ mpi_caf_token_t *mpi_token; ++ MPI_Win *p; ++ ++ *token = calloc(1, sizeof(mpi_caf_token_t)); ++ mpi_token = (mpi_caf_token_t *)(*token); ++ p = TOKEN(mpi_token); ++ mem = desc->base_addr; ++ ierr = MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, ++ CAF_COMM_WORLD, p); ++ chk_err(ierr); ++ CAF_Win_lock_all(*p); ++ mpi_token->owning_memory = 0; ++ ++ struct allocated_tokens_t *allocated_token ++ = malloc(sizeof(struct allocated_tokens_t)); ++ allocated_token->next = current_team->allocated_tokens; ++ allocated_token->token = *token; ++ current_team->allocated_tokens = allocated_token; ++ ++ if (stat) ++ *stat = 0; ++ ++ mpi_token->memptr = mem; ++ dprint("Token %p on exit of mapping: mpi_caf_token_t " ++ "{ (local_)memptr: %p (size: %zd), memptr_win: %d }\n", ++ mpi_token, mpi_token->memptr, size, mpi_token->memptr_win); ++ break; ++ } ++#endif + default: + { + mpi_caf_token_t *mpi_token; +@@ -2168,6 +2205,9 @@ void PREFIX(register)(size_t size, caf_register_t type, caf_token_t *token, + CAF_COMM_WORLD, p); + chk_err(ierr); + #endif // MPI_VERSION ++#ifdef GCC_GE_16 ++ mpi_token->owning_memory = 1; ++#endif + + #ifndef GCC_GE_8 + if (GFC_DESCRIPTOR_RANK(desc) != 0) +@@ -10601,9 +10641,20 @@ PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) + { + struct allocated_tokens_t *nac = ac->next; + +- PREFIX(deregister)((void **)&ac->token, +- CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, errmsg, +- errmsg_len); ++ if (((mpi_caf_token_t *)ac->token)->owning_memory) ++ PREFIX(deregister)((void **)&ac->token, ++ CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, errmsg, ++ errmsg_len); ++ else ++ { ++ MPI_Win *p = TOKEN(ac->token); ++ ++ CAF_Win_unlock_all(*p); ++ ierr = MPI_Win_free(p); ++ chk_err(ierr); ++ ++ free(ac->token); ++ } + free(ac); + ac = nac; + } diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_06_Keep_team_translate_rework.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_06_Keep_team_translate_rework.patch new file mode 100644 index 0000000000..147d203f25 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_06_Keep_team_translate_rework.patch @@ -0,0 +1,32 @@ +From d1ab79d2459f10ca2b239bfeb03aa6e0e30c236b Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Wed, 16 Apr 2025 13:55:46 +0200 +Subject: [PATCH] Keep team_translate rework. + +--- + src/runtime-libraries/mpi/mpi_caf.c | 11 +++++++++++ + 1 file changed, 11 insertions(+) + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 1d6075b5..500a4316 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -5752,7 +5752,18 @@ team_translate(int *remote_image, int *this_image, caf_token_t token, + + #ifdef GCC_GE_16 + if (team) ++ { ++ caf_team_stack_node_t *cur = current_team; ++ while (cur && cur->team_list_elem != *team) ++ cur = cur->parent; ++ if (!cur) ++ { ++ caf_internal_error("Team %d is not active", stat, NULL, 0, ++ (*(caf_teams_list_t **)team)->team_id); ++ return false; ++ } + comm = (*(caf_teams_list_t **)team)->communicator; ++ } + else if (team_number) + { + bool found = false; diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_07_Use_COMM_TEAM_instead_of_COMM_WORLD.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_07_Use_COMM_TEAM_instead_of_COMM_WORLD.patch new file mode 100644 index 0000000000..9ae4912c37 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_07_Use_COMM_TEAM_instead_of_COMM_WORLD.patch @@ -0,0 +1,430 @@ +From 85914915f543ee3ccf1ea0f826f3af0c1d59789f Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Mon, 28 Apr 2025 09:08:06 +0200 +Subject: [PATCH] Use COMM_TEAM instead of COMM_WORLD. + +Revert changes to CAF_COMM_WORLD and introduce CAF_COMM_TEAM. +Let all communication happen on CAF_COMM_WORLD and map the +image indexes accordingly. Use CAF_COMM_TEAM for all collective +ops. +--- + src/runtime-libraries/mpi/mpi_caf.c | 155 ++++++++++++++-------------- + 1 file changed, 78 insertions(+), 77 deletions(-) + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 500a4316..c1599af3 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -358,11 +358,12 @@ typedef struct gfc_max_dim_descriptor_t + + char err_buffer[MPI_MAX_ERROR_STRING]; + +-#ifdef GCC_GE_16 + /* All CAF runtime calls should use this comm instead of MPI_COMM_WORLD for + * interoperability purposes. */ +-MPI_Comm *CAF_COMM_WORLD_store; +-#define CAF_COMM_WORLD (*CAF_COMM_WORLD_store) ++MPI_Comm CAF_COMM_WORLD; ++ ++#ifdef GCC_GE_16 ++#define CAF_COMM_TEAM current_team->team_list_elem->communicator + + typedef struct caf_teams_list + { +@@ -390,10 +391,10 @@ typedef struct caf_team_stack_node + + static caf_teams_list_t *teams_list = NULL; + static caf_team_stack_node_t *current_team = NULL, *initial_team; ++ + #else +-/* All CAF runtime calls should use this comm instead of MPI_COMM_WORLD for +- * interoperability purposes. */ +-MPI_Comm CAF_COMM_WORLD; ++ ++#define CAF_COMM_TEAM CAF_COMM_WORLD + + typedef struct caf_teams_list + { +@@ -1527,9 +1528,6 @@ PREFIX(init)(int *argc, char ***argv) + /* Flag rc as unused, because conditional compilation. */ + int ierr = 0, i = 0, j = 0, rc __attribute__((unused)), prov_lev = 0; + int is_init = 0, prior_thread_level = MPI_THREAD_MULTIPLE; +-#ifdef GCC_GE_16 +- MPI_Comm tmp_world; +-#endif + + ierr = MPI_Initialized(&is_init); + chk_err(ierr); +@@ -1576,12 +1574,8 @@ PREFIX(init)(int *argc, char ***argv) + + /* Duplicate MPI_COMM_WORLD so that no CAF internal functions use it. + * This is critical for MPI-interoperability. */ +-#ifdef GCC_GE_16 +- rc = MPI_Comm_dup(MPI_COMM_WORLD, &tmp_world); +- CAF_COMM_WORLD_store = &tmp_world; +-#else + rc = MPI_Comm_dup(MPI_COMM_WORLD, &CAF_COMM_WORLD); +-#endif ++ + #ifdef WITH_FAILED_IMAGES + flag = (MPI_SUCCESS == rc); + rc = MPIX_Comm_agree(MPI_COMM_WORLD, &flag); +@@ -1625,8 +1619,8 @@ PREFIX(init)(int *argc, char ***argv) + /* BEGIN teams preparations. */ + #ifdef GCC_GE_16 + teams_list = (caf_teams_list_t *)malloc(sizeof(caf_teams_list_t)); +- *teams_list = (struct caf_teams_list){tmp_world, -1, caf_this_image, NULL}; +- CAF_COMM_WORLD_store = &teams_list->communicator; ++ *teams_list ++ = (struct caf_teams_list){CAF_COMM_WORLD, -1, caf_this_image, NULL}; + current_team + = (caf_team_stack_node_t *)malloc(sizeof(caf_team_stack_node_t)); + *current_team = (struct caf_team_stack_node){teams_list, NULL}; +@@ -2162,8 +2156,8 @@ void PREFIX(register)(size_t size, caf_register_t type, caf_token_t *token, + mpi_token = (mpi_caf_token_t *)(*token); + p = TOKEN(mpi_token); + mem = desc->base_addr; +- ierr = MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, +- CAF_COMM_WORLD, p); ++ ierr = MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, CAF_COMM_TEAM, ++ p); + chk_err(ierr); + CAF_Win_lock_all(*p); + mpi_token->owning_memory = 0; +@@ -2194,15 +2188,15 @@ void PREFIX(register)(size_t size, caf_register_t type, caf_token_t *token, + p = TOKEN(mpi_token); + + #if MPI_VERSION >= 3 +- ierr = MPI_Win_allocate(actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, ++ ierr = MPI_Win_allocate(actual_size, 1, MPI_INFO_NULL, CAF_COMM_TEAM, + &mem, p); + chk_err(ierr); + CAF_Win_lock_all(*p); + #else + ierr = MPI_Alloc_mem(actual_size, MPI_INFO_NULL, &mem); + chk_err(ierr); +- ierr = MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, +- CAF_COMM_WORLD, p); ++ ierr = MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, CAF_COMM_TEAM, ++ p); + chk_err(ierr); + #endif // MPI_VERSION + #ifdef GCC_GE_16 +@@ -2415,7 +2409,7 @@ PREFIX(deregister)(caf_token_t *token, int *stat, char *errmsg, + /* Sync all images only, when deregistering the token. Just freeing the + * memory needs no sync. */ + #ifdef WITH_FAILED_IMAGES +- ierr = MPI_Barrier(CAF_COMM_WORLD); ++ ierr = MPI_Barrier(CAF_COMM_TEAM); + chk_err(ierr); + #else + PREFIX(sync_all)(NULL, NULL, 0); +@@ -5742,13 +5736,13 @@ get_from_self(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + } + + bool +-team_translate(int *remote_image, int *this_image, caf_token_t token, +- int image_index, caf_team_t *team, int *team_number, int *stat) ++team_translate(int *remote_image, int *this_image, ++ caf_token_t token __attribute__((unused)), int image_index, ++ caf_team_t *team, int *team_number, int *stat) + { +- MPI_Group current_team_group, win_group; +- int ierr; +- int trans_ranks[2]; +- MPI_Comm comm = CAF_COMM_WORLD; ++ MPI_Group world_group, team_group, remote_group; ++ int ierr, trans, team_id = current_team->team_list_elem->team_id; ++ MPI_Comm remote_comm = MPI_COMM_NULL; + + #ifdef GCC_GE_16 + if (team) +@@ -5762,7 +5756,8 @@ team_translate(int *remote_image, int *this_image, caf_token_t token, + (*(caf_teams_list_t **)team)->team_id); + return false; + } +- comm = (*(caf_teams_list_t **)team)->communicator; ++ remote_comm = (*(caf_teams_list_t **)team)->communicator; ++ team_id = (*(caf_teams_list_t **)team)->team_id; + } + else if (team_number) + { +@@ -5770,7 +5765,8 @@ team_translate(int *remote_image, int *this_image, caf_token_t token, + for (caf_team_stack_node_t *cur = current_team; cur; cur = cur->parent) + if (cur->team_list_elem->team_id == *team_number) + { +- comm = cur->team_list_elem->communicator; ++ remote_comm = cur->team_list_elem->communicator; ++ team_id = cur->team_list_elem->team_id; + found = true; + break; + } +@@ -5783,20 +5779,30 @@ team_translate(int *remote_image, int *this_image, caf_token_t token, + } + #endif + +- ierr = MPI_Comm_group(comm, ¤t_team_group); ++ ierr = MPI_Comm_group(CAF_COMM_WORLD, &world_group); + chk_err(ierr); +- ierr = MPI_Win_get_group(*TOKEN(token), &win_group); ++ if (remote_comm == MPI_COMM_NULL) ++ ierr = MPI_Comm_group(CAF_COMM_TEAM, &remote_group); ++ else ++ ierr = MPI_Comm_group(remote_comm, &remote_group); + chk_err(ierr); +- ierr = MPI_Group_translate_ranks(current_team_group, 2, +- (int[]){image_index - 1, mpi_this_image}, +- win_group, trans_ranks); ++ ierr = MPI_Comm_group(CAF_COMM_TEAM, &team_group); + chk_err(ierr); +- *remote_image = trans_ranks[0]; +- *this_image = trans_ranks[1]; +- ierr = MPI_Group_free(¤t_team_group); ++ trans = image_index - 1; ++ ierr = MPI_Group_translate_ranks(team_group, 1, &mpi_this_image, world_group, ++ this_image); + chk_err(ierr); +- ierr = MPI_Group_free(&win_group); ++ ierr = MPI_Group_translate_ranks(remote_group, 1, &trans, world_group, ++ remote_image); ++ chk_err(ierr); ++ ierr = MPI_Group_free(&remote_group); ++ chk_err(ierr); ++ ierr = MPI_Group_free(&team_group); + chk_err(ierr); ++ ierr = MPI_Group_free(&world_group); ++ chk_err(ierr); ++ dprint("this: %d -> %d, rmt: %d -> %d on team %d.\n", caf_this_image, ++ *this_image + 1, image_index, *remote_image + 1, team_id); + return true; + } + +@@ -5889,7 +5895,7 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + msg->transfer_size = dst_size; + msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + msg->win = *TOKEN(token); +- msg->dest_image = mpi_this_image; ++ msg->dest_image = this_image; + msg->dest_tag = CAF_CT_TAG + 1; + msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + msg->flags = (opt_dst_desc ? CT_DST_HAS_DESC : 0) +@@ -5932,13 +5938,12 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + caf_runtime_error("Unable to allocate memory " + "for internal buffer in get_from_remote()."); + } +- dprint("waiting to receive %zd bytes from %d.\n", dst_size, +- image_index - 1); +- ierr = MPI_Recv(t_buff, dst_size, MPI_BYTE, image_index - 1, msg->dest_tag, ++ dprint("waiting to receive %zd bytes from %d.\n", dst_size, remote_image); ++ ierr = MPI_Recv(t_buff, dst_size, MPI_BYTE, remote_image, msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); + chk_err(ierr); + dprint("received %zd bytes as requested from %d.\n", dst_size, +- image_index - 1); ++ remote_image); + // dump_mem("get_from_remote", t_buff, dst_size); + memcpy(*dst_data, t_buff, dst_size); + +@@ -6276,7 +6281,7 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + msg->transfer_size = src_size; + msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + msg->win = *TOKEN(token); +- msg->dest_image = mpi_this_image; ++ msg->dest_image = this_image; + msg->dest_tag = CAF_CT_TAG + 1; + msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + msg->flags = (opt_dst_desc ? CT_DST_HAS_DESC : 0) +@@ -6317,13 +6322,13 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + + { + char c; +- dprint("waiting to receive %d bytes from %d on tag %d.\n", 1, image_index, ++ dprint("waiting to receive 1 byte from %d on tag %d.\n", remote_image, + msg->dest_tag); +- ierr = MPI_Recv(&c, 1, MPI_BYTE, image_index - 1, msg->dest_tag, ++ ierr = MPI_Recv(&c, 1, MPI_BYTE, remote_image, msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); + chk_err(ierr); +- dprint("received %d bytes as requested from %d on tag %d.\n", 1, +- image_index, msg->dest_tag); ++ dprint("received 1 byte as requested from %d on tag %d.\n", remote_image, ++ msg->dest_tag); + } + + if (running_accesses == rat) +@@ -6383,9 +6388,7 @@ PREFIX(transfer_between_remotes)( + caf_team_t *dst_team, int *dst_team_number, caf_team_t *src_team, + int *src_team_number) + { +- MPI_Group current_team_group, win_group; + int ierr, this_image, src_remote_image, dst_remote_image; +- int trans_ranks[3]; + bool free_msg; + ct_msg_t *full_msg, *dst_msg; + struct transfer_msg_data_t *tmd; +@@ -6545,7 +6548,7 @@ PREFIX(transfer_between_remotes)( + dst_msg->transfer_size = src_size; + dst_msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + dst_msg->win = *TOKEN(dst_token); +- dst_msg->dest_image = mpi_this_image; ++ dst_msg->dest_image = this_image; + dst_msg->dest_tag = CAF_CT_TAG + 1; + dst_msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + dst_msg->flags +@@ -6588,15 +6591,15 @@ PREFIX(transfer_between_remotes)( + + { + char c; +- dprint("waiting to receive %d bytes from %d on tag %d.\n", 1, +- dst_image_index, dst_msg->dest_tag); +- ierr = MPI_Recv(&c, 1, MPI_BYTE, dst_image_index - 1, dst_msg->dest_tag, ++ dprint("waiting to receive 1 byte from %d on tag %d.\n", dst_remote_image, ++ dst_msg->dest_tag); ++ ierr = MPI_Recv(&c, 1, MPI_BYTE, dst_remote_image, dst_msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); + chk_err(ierr); + if (dst_stat) + *dst_stat = c; +- dprint("received %d bytes as requested from %d on tag %d.\n", 1, +- dst_image_index, dst_msg->dest_tag); ++ dprint("received 1 byte as requested from %d on tag %d.\n", ++ dst_remote_image, dst_msg->dest_tag); + } + + if (running_accesses == rat) +@@ -9509,19 +9512,19 @@ internal_co_reduce(MPI_Op op, gfc_descriptor_t *source, int result_image, + if (result_image == 0) + { + ierr = MPI_Allreduce(MPI_IN_PLACE, source->base_addr, size, datatype, op, +- CAF_COMM_WORLD); ++ CAF_COMM_TEAM); + chk_err(ierr); + } + else if (result_image == caf_this_image) + { + ierr = MPI_Reduce(MPI_IN_PLACE, source->base_addr, size, datatype, op, +- result_image - 1, CAF_COMM_WORLD); ++ result_image - 1, CAF_COMM_TEAM); + chk_err(ierr); + } + else + { + ierr = MPI_Reduce(source->base_addr, NULL, size, datatype, op, +- result_image - 1, CAF_COMM_WORLD); ++ result_image - 1, CAF_COMM_TEAM); + chk_err(ierr); + } + if (ierr) +@@ -9543,19 +9546,19 @@ internal_co_reduce(MPI_Op op, gfc_descriptor_t *source, int result_image, + + array_offset_sr * GFC_DESCRIPTOR_SIZE(source)); + if (result_image == 0) + { +- ierr = MPI_Allreduce(MPI_IN_PLACE, sr, 1, datatype, op, CAF_COMM_WORLD); ++ ierr = MPI_Allreduce(MPI_IN_PLACE, sr, 1, datatype, op, CAF_COMM_TEAM); + chk_err(ierr); + } + else if (result_image == caf_this_image) + { + ierr = MPI_Reduce(MPI_IN_PLACE, sr, 1, datatype, op, result_image - 1, +- CAF_COMM_WORLD); ++ CAF_COMM_TEAM); + chk_err(ierr); + } + else + { + ierr = MPI_Reduce(sr, NULL, 1, datatype, op, result_image - 1, +- CAF_COMM_WORLD); ++ CAF_COMM_TEAM); + chk_err(ierr); + } + if (ierr) +@@ -9618,13 +9621,13 @@ PREFIX(co_broadcast)(gfc_descriptor_t *a, int source_image, int *stat, + if (datatype == MPI_BYTE) + { + ierr = MPI_Bcast(a->base_addr, size * GFC_DESCRIPTOR_SIZE(a), datatype, +- source_image - 1, CAF_COMM_WORLD); ++ source_image - 1, CAF_COMM_TEAM); + chk_err(ierr); + } + else if (datatype != MPI_CHARACTER) + { + ierr = MPI_Bcast(a->base_addr, size, datatype, source_image - 1, +- CAF_COMM_WORLD); ++ CAF_COMM_TEAM); + chk_err(ierr); + } + else +@@ -9633,13 +9636,13 @@ PREFIX(co_broadcast)(gfc_descriptor_t *a, int source_image, int *stat, + if (caf_this_image == source_image) + a_length = strlen(a->base_addr); + /* Broadcast the string lenth */ +- ierr = MPI_Bcast(&a_length, 1, MPI_INT, source_image - 1, CAF_COMM_WORLD); ++ ierr = MPI_Bcast(&a_length, 1, MPI_INT, source_image - 1, CAF_COMM_TEAM); + chk_err(ierr); + if (ierr) + goto error; + /* Broadcast the string itself */ + ierr = MPI_Bcast(a->base_addr, a_length, datatype, source_image - 1, +- CAF_COMM_WORLD); ++ CAF_COMM_TEAM); + chk_err(ierr); + } + +@@ -9668,7 +9671,7 @@ PREFIX(co_broadcast)(gfc_descriptor_t *a, int source_image, int *stat, + void *sr = (void *)((char *)a->base_addr + + array_offset * GFC_DESCRIPTOR_SIZE(a)); + +- ierr = MPI_Bcast(sr, 1, datatype, source_image - 1, CAF_COMM_WORLD); ++ ierr = MPI_Bcast(sr, 1, datatype, source_image - 1, CAF_COMM_TEAM); + chk_err(ierr); + + if (ierr) +@@ -10426,7 +10429,7 @@ PREFIX(form_team)(int team_id, caf_team_t *team, int *new_index, int *stat, + static const char *negative_new_index + = "FORM TEAM: NEW_INDEX= shall be a positive unique integer"; + caf_teams_list_t *new_team; +- MPI_Comm current_comm = CAF_COMM_WORLD; ++ MPI_Comm current_comm = CAF_COMM_TEAM; + int ierr; + int key = new_index ? *new_index : caf_this_image; + +@@ -10504,13 +10507,12 @@ PREFIX(change_team)(caf_team_t team, int *stat, char *errmsg, + = (caf_team_stack_node_t){provisioned_team, NULL, current_team}; + + current_team = new_current_team; +- CAF_COMM_WORLD_store = ¤t_team->team_list_elem->communicator; +- ierr = MPI_Comm_rank(CAF_COMM_WORLD, &mpi_this_image); ++ ierr = MPI_Comm_rank(CAF_COMM_TEAM, &mpi_this_image); + chk_err(ierr); + caf_this_image = mpi_this_image + 1; +- ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); ++ ierr = MPI_Comm_size(CAF_COMM_TEAM, &caf_num_images); + chk_err(ierr); +- ierr = MPI_Barrier(CAF_COMM_WORLD); ++ ierr = MPI_Barrier(CAF_COMM_TEAM); + chk_err(ierr); + dprint("changed to team %d.\n", current_team->team_list_elem->team_id); + } +@@ -10638,7 +10640,7 @@ PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) + if (stat) + *stat = 0; + +- ierr = MPI_Barrier(CAF_COMM_WORLD); ++ ierr = MPI_Barrier(CAF_COMM_TEAM); + chk_err(ierr); + if (current_team->parent == NULL) + { +@@ -10671,11 +10673,10 @@ PREFIX(end_team)(int *stat, char *errmsg, charlen_t errmsg_len) + } + current_team = current_team->parent; + +- CAF_COMM_WORLD_store = ¤t_team->team_list_elem->communicator; +- ierr = MPI_Comm_rank(CAF_COMM_WORLD, &mpi_this_image); ++ ierr = MPI_Comm_rank(CAF_COMM_TEAM, &mpi_this_image); + chk_err(ierr); + caf_this_image = mpi_this_image + 1; +- ierr = MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images); ++ ierr = MPI_Comm_size(CAF_COMM_TEAM, &caf_num_images); + chk_err(ierr); + free(ending_team); + dprint("switched to team %d.\n", current_team->team_list_elem->team_id); diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_08_Add_more_beefy_tests.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_08_Add_more_beefy_tests.patch new file mode 100644 index 0000000000..267359ed83 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_08_Add_more_beefy_tests.patch @@ -0,0 +1,232 @@ +From a13970883e7b9cc7989efd7877534252c0317f06 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Thu, 17 Apr 2025 11:57:47 +0200 +Subject: [PATCH] Add more "beefy" tests. + +Add tests that really make use of teams and not only a smoke test. +--- + CMakeLists.txt | 4 +- + src/tests/unit/teams/CMakeLists.txt | 2 + + src/tests/unit/teams/teams_coindexed.f90 | 111 +++++++++++++++++++++++ + src/tests/unit/teams/test_teams_1.f90 | 66 ++++++++++++++ + 4 files changed, 182 insertions(+), 1 deletion(-) + create mode 100644 src/tests/unit/teams/teams_coindexed.f90 + create mode 100644 src/tests/unit/teams/test_teams_1.f90 + +diff --git a/CMakeLists.txt b/CMakeLists.txt +index 8f9ee35a..0dbb85a0 100644 +--- a/CMakeLists.txt ++++ b/CMakeLists.txt +@@ -818,9 +818,11 @@ if(opencoarrays_aware_compiler) + add_caf_test(alloc_comp_multidim_shape 2 alloc_comp_multidim_shape) + set_tests_properties(alloc_comp_multidim_shape PROPERTIES TIMEOUT 300) + endif() +- if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 15) ++ if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16) + add_caf_test(teams_this_image 8 teams_this_image) + add_caf_test(teams_num_images 8 teams_num_images) ++ add_caf_test(test_teams_1 9 test_teams_1) ++ add_caf_test(teams_coindexed 2 teams_coindexed) + endif() + endif() + +diff --git a/src/tests/unit/teams/CMakeLists.txt b/src/tests/unit/teams/CMakeLists.txt +index 8307b078..2ef2ee8e 100644 +--- a/src/tests/unit/teams/CMakeLists.txt ++++ b/src/tests/unit/teams/CMakeLists.txt +@@ -10,4 +10,6 @@ caf_compile_executable(sync_team sync-team.f90) + if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0.0)) + caf_compile_executable(teams_this_image teams_this_image.f90) + caf_compile_executable(teams_num_images teams_num_images.f90) ++ caf_compile_executable(test_teams_1 test_teams_1.f90) ++ caf_compile_executable(teams_coindexed teams_coindexed.f90) + endif() +diff --git a/src/tests/unit/teams/teams_coindexed.f90 b/src/tests/unit/teams/teams_coindexed.f90 +new file mode 100644 +index 00000000..5c3fab91 +--- /dev/null ++++ b/src/tests/unit/teams/teams_coindexed.f90 +@@ -0,0 +1,111 @@ ++! BSD 3-Clause License ++! ++! Copyright (c) 2018-2025, Sourcery Institute ++! All rights reserved. ++! ++! Redistribution and use in source and binary forms, with or without ++! modification, are permitted provided that the following conditions are met: ++! ++! * Redistributions of source code must retain the above copyright notice, this ++! list of conditions and the following disclaimer. ++! ++! * Redistributions in binary form must reproduce the above copyright notice, ++! this list of conditions and the following disclaimer in the documentation ++! and/or other materials provided with the distribution. ++! ++! * Neither the name of the copyright holder nor the names of its ++! contributors may be used to endorse or promote products derived from ++! this software without specific prior written permission. ++! ++! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ++! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE ++! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ++! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ++! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ++! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ++! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++ ++program teams_coindexed ++ use, intrinsic :: iso_fortran_env ++ ++ type(team_type) :: parentteam, team, formed_team ++ integer :: t_num= 42, stat = 42, lhs ++ integer(kind=2) :: st_num=42 ++ integer :: caf(2)[*] ++ ++ parentteam = get_team() ++ ++ caf = [23, 32] ++ form team(t_num, team) ++ form team(t_num, formed_team) ++ ++ associate(me => this_image()) ++ change team(team, cell[*] => caf(2)) ++ ! 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[me, 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 ++ ++ ! 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[me, 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 ++ ++ ! 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[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[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 ++ end team ++ ++ sync all ++ if (me == 1) print *, "Test passed." ++ end associate ++end program teams_coindexed +diff --git a/src/tests/unit/teams/test_teams_1.f90 b/src/tests/unit/teams/test_teams_1.f90 +new file mode 100644 +index 00000000..3d94c535 +--- /dev/null ++++ b/src/tests/unit/teams/test_teams_1.f90 +@@ -0,0 +1,66 @@ ++! BSD 3-Clause License ++! ++! Copyright (c) 2018-2025, Sourcery Institute ++! All rights reserved. ++! ++! Redistribution and use in source and binary forms, with or without ++! modification, are permitted provided that the following conditions are met: ++! ++! * Redistributions of source code must retain the above copyright notice, this ++! list of conditions and the following disclaimer. ++! ++! * Redistributions in binary form must reproduce the above copyright notice, ++! this list of conditions and the following disclaimer in the documentation ++! and/or other materials provided with the distribution. ++! ++! * Neither the name of the copyright holder nor the names of its ++! contributors may be used to endorse or promote products derived from ++! this software without specific prior written permission. ++! ++! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ++! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ++! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ++! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE ++! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ++! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ++! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER ++! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, ++! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ++! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++ ++program test_teams_1 ++ use, intrinsic :: iso_fortran_env ++ use oc_assertions_interface, only : assert ++ ++ integer :: caf(3,3)[*] != 42 ++ type(team_type) :: row_team, column_team ++ ++ caf = reshape((/(-i, i = 1, 9 )/), [3,3]) ++ associate(me => this_image(), np => num_images()) ++ call assert(np == 9, "I need exactly 9 teams.") ++ ++ ! Form a row team ++ form team((me - 1) / 3 + 1, row_team, new_index=mod(me - 1, 3) + 1) ++ row_t: change team(row_team, row[*] => caf(:, team_number(row_team))) ++ ! Form column teams; each team has only one image ++ form team (team_number(), column_team) ++ col_t: change team(column_team, cell[*] => row(this_image())) ++ cell = team_number() ++ if (this_image() /= 1) row(this_image())[1] = cell ++ end team col_t ++ sync team(row_team) ++ if (this_image() == 1) caf(:, team_number(row_team))[1, team_number = -1] = row ++ end team row_t ++ sync all ++ if (me == 1) then ++ if (all(caf == reshape([1,1,1,2,2,2,3,3,3], [3, 3]))) then ++ print *, "Test passed." ++ else ++ print *, "Test failed." ++ print *, "Expected:", reshape([1,1,1,2,2,2,3,3,3], [3, 3]) ++ print *, "Got :", caf ++ end if ++ end if ++ end associate ++ ++end program test_teams_1 diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_09_Add_comments_to_teams_num_images_test.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_09_Add_comments_to_teams_num_images_test.patch new file mode 100644 index 0000000000..6658bc9df9 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_09_Add_comments_to_teams_num_images_test.patch @@ -0,0 +1,29 @@ +From 9c740b95f62bf1fc5bffed475e8f2bd2f471d830 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Thu, 17 Apr 2025 15:42:36 +0200 +Subject: [PATCH] Add comments to teams_num_images test. + +--- + src/tests/unit/teams/teams_num_images.f90 | 3 +++ + 1 file changed, 3 insertions(+) + +diff --git a/src/tests/unit/teams/teams_num_images.f90 b/src/tests/unit/teams/teams_num_images.f90 +index b90a9105..9f539676 100644 +--- a/src/tests/unit/teams/teams_num_images.f90 ++++ b/src/tests/unit/teams/teams_num_images.f90 +@@ -35,12 +35,15 @@ + sync all + form team(MOD(me, 2) + 1, team) + ++ ! Test no parameter gives all images in curren team. + j1 = num_images() + if (j1 /= num) stop 1 + ++ ! Test that a team_type parameter gives the #images in that team. + j2 = num_images(team) + if (j2 /= num / 2) stop 2 + ++ ! Same but using the number of the team. + j3 = num_images(MOD(me, 2) + 1) + if (j3 /= num / 2) stop 3 + diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_10_Fixes_for_use_with_gcc_lt_16.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_10_Fixes_for_use_with_gcc_lt_16.patch new file mode 100644 index 0000000000..8e56b93307 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_10_Fixes_for_use_with_gcc_lt_16.patch @@ -0,0 +1,224 @@ +From 3d5c515ae0ff4636a5d3272ce838c2873d117b98 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Mon, 28 Apr 2025 09:42:27 +0200 +Subject: [PATCH] Fixes for use with gcc<16. + +--- + CMakeLists.txt | 4 +- + src/runtime-libraries/mpi/mpi_caf.c | 72 ++++++++++++++++++++++++++-- + src/tests/unit/teams/team_number.F90 | 2 +- + 3 files changed, 70 insertions(+), 8 deletions(-) + +diff --git a/CMakeLists.txt b/CMakeLists.txt +index 0dbb85a0..e9694b4e 100644 +--- a/CMakeLists.txt ++++ b/CMakeLists.txt +@@ -233,10 +233,10 @@ endif() + if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 8.0.0 ) ) + add_definitions(-DGCC_GE_8) # Tell library to build against GFortran 8.x bindings w/ descriptor change + endif() +- if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 15.0.0 ) ) ++ if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS_EQUAL 15.0.0 ) ) + add_definitions(-DGCC_GE_15) # Tell library to build against GFortran 15.x bindings + endif() +- if ( gfortran_compiler AND ( NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 16.0.0 ) ) ++ if ( gfortran_compiler AND ( CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 16.0.0 ) ) + add_definitions(-DGCC_GE_16) # Tell library to build against GFortran 16.x bindings + endif() + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index c1599af3..91784a52 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -226,7 +226,7 @@ static win_sync *pending_puts = NULL; + /* Linked list of static coarrays registered. Do not expose to public in the + * header, because it is implementation specific. + * +- * From gcc-15 on, this list is contained in the teams handling. */ ++ * From gcc-16 on, this list is contained in the teams handling. */ + struct caf_allocated_tokens_t + { + caf_token_t token; +@@ -839,7 +839,11 @@ handle_is_present_message(ct_msg_t *msg, void *baseptr) + += sizeof_desc_for_rank(GFC_DESCRIPTOR_RANK((gfc_descriptor_t *)ptr)); + } + else ++#ifdef GCC_GE_16 + ptr = &baseptr; ++#else ++ ptr = baseptr; ++#endif + + accessor_hash_table[msg->accessor_index].u.is_present( + add_data, &msg->dest_image, &result, ptr, &src_token, 0); +@@ -5740,11 +5744,11 @@ team_translate(int *remote_image, int *this_image, + caf_token_t token __attribute__((unused)), int image_index, + caf_team_t *team, int *team_number, int *stat) + { ++#ifdef GCC_GE_16 + MPI_Group world_group, team_group, remote_group; + int ierr, trans, team_id = current_team->team_list_elem->team_id; + MPI_Comm remote_comm = MPI_COMM_NULL; + +-#ifdef GCC_GE_16 + if (team) + { + caf_team_stack_node_t *cur = current_team; +@@ -5777,7 +5781,6 @@ team_translate(int *remote_image, int *this_image, + return false; + } + } +-#endif + + ierr = MPI_Comm_group(CAF_COMM_WORLD, &world_group); + chk_err(ierr); +@@ -5803,6 +5806,27 @@ team_translate(int *remote_image, int *this_image, + chk_err(ierr); + dprint("this: %d -> %d, rmt: %d -> %d on team %d.\n", caf_this_image, + *this_image + 1, image_index, *remote_image + 1, team_id); ++#else ++ MPI_Group current_team_group, win_group; ++ int ierr, trans_ranks[2]; ++ ++ ierr = MPI_Comm_group(CAF_COMM_WORLD, ¤t_team_group); ++ chk_err(ierr); ++ ierr = MPI_Win_get_group(*TOKEN(token), &win_group); ++ chk_err(ierr); ++ ierr = MPI_Group_translate_ranks(current_team_group, 2, ++ (int[]){image_index - 1, mpi_this_image}, ++ win_group, trans_ranks); ++ chk_err(ierr); ++ *remote_image = trans_ranks[0]; ++ *this_image = trans_ranks[1]; ++ ierr = MPI_Group_free(¤t_team_group); ++ chk_err(ierr); ++ ierr = MPI_Group_free(&win_group); ++ chk_err(ierr); ++ dprint("this: %d -> %d, rmt: %d -> %d.\n", caf_this_image, *this_image + 1, ++ image_index, *remote_image + 1); ++#endif + return true; + } + +@@ -5895,7 +5919,11 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + msg->transfer_size = dst_size; + msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + msg->win = *TOKEN(token); ++#ifdef GCC_GE_16 + msg->dest_image = this_image; ++#else ++ msg->dest_image = mpi_this_image; ++#endif + msg->dest_tag = CAF_CT_TAG + 1; + msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + msg->flags = (opt_dst_desc ? CT_DST_HAS_DESC : 0) +@@ -5939,8 +5967,13 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + "for internal buffer in get_from_remote()."); + } + dprint("waiting to receive %zd bytes from %d.\n", dst_size, remote_image); ++#ifdef GCC_GE_16 + ierr = MPI_Recv(t_buff, dst_size, MPI_BYTE, remote_image, msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#else ++ ierr = MPI_Recv(t_buff, dst_size, MPI_BYTE, image_index - 1, msg->dest_tag, ++ CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#endif + chk_err(ierr); + dprint("received %zd bytes as requested from %d.\n", dst_size, + remote_image); +@@ -5958,8 +5991,13 @@ PREFIX(get_from_remote)(caf_token_t token, const gfc_descriptor_t *opt_src_desc, + + dprint("probing for incoming message from %d, tag %d.\n", image_index - 1, + msg->dest_tag); ++#ifdef GCC_GE_16 ++ ierr = MPI_Mprobe(remote_image, msg->dest_tag, CAF_COMM_WORLD, &msg_han, ++ &status); ++#else + ierr = MPI_Mprobe(image_index - 1, msg->dest_tag, CAF_COMM_WORLD, &msg_han, + &status); ++#endif + chk_err(ierr); + if (ierr == MPI_SUCCESS) + { +@@ -6062,8 +6100,14 @@ PREFIX(is_present_on_remote)(caf_token_t token, const int image_index, + void *src_ptr = ((mpi_caf_token_t *)token)->memptr; + + dprint("Shortcutting due to self access on image %d.\n", image_index); +- accessor_hash_table[is_present_index].u.is_present( +- add_data, &this_image, &result, &src_ptr, &src_token, 0); ++ accessor_hash_table[is_present_index].u.is_present(add_data, &this_image, ++ &result, ++#ifdef GCC_GE_16 ++ &src_ptr, ++#else ++ src_ptr, ++#endif ++ &src_token, 0); + + return result; + } +@@ -6281,7 +6325,11 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + msg->transfer_size = src_size; + msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + msg->win = *TOKEN(token); ++#ifdef GCC_GE_16 + msg->dest_image = this_image; ++#else ++ msg->dest_image = mpi_this_image; ++#endif + msg->dest_tag = CAF_CT_TAG + 1; + msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + msg->flags = (opt_dst_desc ? CT_DST_HAS_DESC : 0) +@@ -6324,8 +6372,13 @@ PREFIX(send_to_remote)(caf_token_t token, gfc_descriptor_t *opt_dst_desc, + char c; + dprint("waiting to receive 1 byte from %d on tag %d.\n", remote_image, + msg->dest_tag); ++#ifdef GCC_GE_16 + ierr = MPI_Recv(&c, 1, MPI_BYTE, remote_image, msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#else ++ ierr = MPI_Recv(&c, 1, MPI_BYTE, image_index - 1, msg->dest_tag, ++ CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#endif + chk_err(ierr); + dprint("received 1 byte as requested from %d on tag %d.\n", remote_image, + msg->dest_tag); +@@ -6548,7 +6601,11 @@ PREFIX(transfer_between_remotes)( + dst_msg->transfer_size = src_size; + dst_msg->opt_charlen = opt_src_charlen ? *opt_src_charlen : 0; + dst_msg->win = *TOKEN(dst_token); ++#ifdef GCC_GE_16 + dst_msg->dest_image = this_image; ++#else ++ dst_msg->dest_image = mpi_this_image; ++#endif + dst_msg->dest_tag = CAF_CT_TAG + 1; + dst_msg->dest_opt_charlen = opt_dst_charlen ? *opt_dst_charlen : 1; + dst_msg->flags +@@ -6593,8 +6650,13 @@ PREFIX(transfer_between_remotes)( + char c; + dprint("waiting to receive 1 byte from %d on tag %d.\n", dst_remote_image, + dst_msg->dest_tag); ++#ifdef GCC_GE_16 + ierr = MPI_Recv(&c, 1, MPI_BYTE, dst_remote_image, dst_msg->dest_tag, + CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#else ++ ierr = MPI_Recv(&c, 1, MPI_BYTE, dst_image_index - 1, dst_msg->dest_tag, ++ CAF_COMM_WORLD, MPI_STATUS_IGNORE); ++#endif + chk_err(ierr); + if (dst_stat) + *dst_stat = c; +diff --git a/src/tests/unit/teams/team_number.F90 b/src/tests/unit/teams/team_number.F90 +index a50ebd67..07d15778 100644 +--- a/src/tests/unit/teams/team_number.F90 ++++ b/src/tests/unit/teams/team_number.F90 +@@ -43,7 +43,7 @@ program main + + call assert(team_number()==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") + +-#ifdef GCC_GE_15 ++#ifdef GCC_GE_16 + call assert(team_number(get_team(current_team))==standard_initial_value,"initial team number conforms with Fortran standard before 'change team'") + #endif + diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_11_Ensure_gcc-16_compatibility.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_11_Ensure_gcc-16_compatibility.patch new file mode 100644 index 0000000000..eb1b182b14 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_11_Ensure_gcc-16_compatibility.patch @@ -0,0 +1,71 @@ +From 8d19ac523d137d6738eb6091cd1695b4d798c044 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Fri, 4 Jul 2025 13:53:18 +0200 +Subject: [PATCH] Ensure gcc-16 compatibility. + +Fix is_present for descriptor arrays in gcc-16. +Remove compiling warning from test_case. +--- + src/runtime-libraries/mpi/mpi_caf.c | 16 ++++++++-------- + src/tests/unit/collectives/co_reduce_string.f90 | 5 ++--- + 2 files changed, 10 insertions(+), 11 deletions(-) + +diff --git a/src/runtime-libraries/mpi/mpi_caf.c b/src/runtime-libraries/mpi/mpi_caf.c +index 91784a529..f235ae792 100644 +--- a/src/runtime-libraries/mpi/mpi_caf.c ++++ b/src/runtime-libraries/mpi/mpi_caf.c +@@ -6095,19 +6095,19 @@ PREFIX(is_present_on_remote)(caf_token_t token, const int image_index, + + if (this_image == remote_image) + { ++ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *)token; + int32_t result = 0; + mpi_caf_token_t src_token = {get_data, MPI_WIN_NULL, NULL}; +- void *src_ptr = ((mpi_caf_token_t *)token)->memptr; +- +- dprint("Shortcutting due to self access on image %d.\n", image_index); +- accessor_hash_table[is_present_index].u.is_present(add_data, &this_image, +- &result, + #ifdef GCC_GE_16 +- &src_ptr, ++ void *src_ptr ++ = mpi_token->desc ? mpi_token->desc : (void *)&mpi_token->memptr; + #else +- src_ptr, ++ void *src_ptr = mpi_token->memptr; + #endif +- &src_token, 0); ++ ++ dprint("Shortcutting due to self access on image %d.\n", image_index); ++ accessor_hash_table[is_present_index].u.is_present( ++ add_data, &this_image, &result, src_ptr, &src_token, 0); + + return result; + } +diff --git a/src/tests/unit/collectives/co_reduce_string.f90 b/src/tests/unit/collectives/co_reduce_string.f90 +index ad094f92a..7b7dad797 100644 +--- a/src/tests/unit/collectives/co_reduce_string.f90 ++++ b/src/tests/unit/collectives/co_reduce_string.f90 +@@ -40,7 +40,7 @@ program co_reduce_strings + associate (me => this_image()) + allocate(strarr(numstrings)[*]) + do i = 1, numstrings +- write(strarr(i), "('foo'I02)") i * me ++ write(strarr(i), "('foo',I02)") i * me + end do + ! Collectively reduce the maximum string. + call co_reduce(strarr, strmax) +@@ -50,7 +50,7 @@ program co_reduce_strings + ! implicitly synchronizes. + associate (np => num_images()) + do i = 1, np +- write (expect, "('foo'I02)") i * np ++ write (expect, "('foo',I02)") i * np + if (strarr(i) /= expect) then + ! On errror print what we got and what we expected. + print *, "Got: ", strarr(i), ", expected: ", expect +@@ -77,4 +77,3 @@ pure function strmax(lhs, rhs) result(maxstr) bind(C,name="strmax") + end function + + end program co_reduce_strings +- diff --git a/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_12_Fix_teams_testcase.patch b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_12_Fix_teams_testcase.patch new file mode 100644 index 0000000000..eb9db28ef1 --- /dev/null +++ b/sys-cluster/opencoarrays/files/opencoarrays-2.10.3_patch_12_Fix_teams_testcase.patch @@ -0,0 +1,27 @@ +From 74a5d0ac3f2d6ee5f985a13478a87f309a444b07 Mon Sep 17 00:00:00 2001 +From: Andre Vehreschild +Date: Wed, 9 Jul 2025 13:33:13 +0200 +Subject: [PATCH] Fix team's testcase. + +--- + src/tests/unit/teams/test_teams_1.f90 | 6 +++--- + 1 file changed, 3 insertions(+), 3 deletions(-) + +diff --git a/src/tests/unit/teams/test_teams_1.f90 b/src/tests/unit/teams/test_teams_1.f90 +index 3d94c535..b3f6523d 100644 +--- a/src/tests/unit/teams/test_teams_1.f90 ++++ b/src/tests/unit/teams/test_teams_1.f90 +@@ -43,10 +43,10 @@ program test_teams_1 + form team((me - 1) / 3 + 1, row_team, new_index=mod(me - 1, 3) + 1) + row_t: change team(row_team, row[*] => caf(:, team_number(row_team))) + ! Form column teams; each team has only one image +- form team (team_number(), column_team) ++ form team (this_image(), column_team) + col_t: change team(column_team, cell[*] => row(this_image())) +- cell = team_number() +- if (this_image() /= 1) row(this_image())[1] = cell ++ cell = team_number(row_team) ++ if (this_image(row_team) /= 1) row(this_image(row_team))[1, team=row_team] = cell + end team col_t + sync team(row_team) + if (this_image() == 1) caf(:, team_number(row_team))[1, team_number = -1] = row diff --git a/sys-cluster/opencoarrays/opencoarrays-2.10.3.ebuild b/sys-cluster/opencoarrays/opencoarrays-2.10.3_p20251223.ebuild similarity index 55% rename from sys-cluster/opencoarrays/opencoarrays-2.10.3.ebuild rename to sys-cluster/opencoarrays/opencoarrays-2.10.3_p20251223.ebuild index 480e11ea4d..653d74e852 100644 --- a/sys-cluster/opencoarrays/opencoarrays-2.10.3.ebuild +++ b/sys-cluster/opencoarrays/opencoarrays-2.10.3_p20251223.ebuild @@ -9,12 +9,13 @@ FORTRAN_STANDARD="2003" inherit cmake flag-o-matic fortran-2 MY_PN="OpenCoarrays" +MY_PV="${PV%_*}" DESCRIPTION="A parallel application binary interface for Fortran 2018 compilers" HOMEPAGE="http://www.opencoarrays.org/" -SRC_URI="https://github.com/sourceryinstitute/${MY_PN}/archive/refs/tags/${PV}.tar.gz -> ${MY_PN}-${PV}.tar.gz" +SRC_URI="https://github.com/sourceryinstitute/${MY_PN}/archive/refs/tags/${MY_PV}.tar.gz -> ${MY_PN}-${PV}.tar.gz" -S="${WORKDIR}/${MY_PN}-${PV}" +S="${WORKDIR}/${MY_PN}-${MY_PV}" LICENSE="BSD" SLOT="0" @@ -37,6 +38,21 @@ DEPEND=" ${RDEPEND} " +PATCHES=( + "${FILESDIR}/${PN}-${MY_PV}_patch_01_Improve_teams_implementation.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_02_Fix_team_number.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_03_Remove_wrong_error.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_04_Enchance_debug_logging.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_05_Add_owning_memory_flag.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_06_Keep_team_translate_rework.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_07_Use_COMM_TEAM_instead_of_COMM_WORLD.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_08_Add_more_beefy_tests.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_09_Add_comments_to_teams_num_images_test.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_10_Fixes_for_use_with_gcc_lt_16.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_11_Ensure_gcc-16_compatibility.patch" + "${FILESDIR}/${PN}-${MY_PV}_patch_12_Fix_teams_testcase.patch" +) + src_configure() { filter-lto # Bug 860765