diff options
Diffstat (limited to 'libgfortran')
| -rw-r--r-- | libgfortran/ChangeLog | 72 | ||||
| -rw-r--r-- | libgfortran/caf/libcaf.h | 46 | ||||
| -rw-r--r-- | libgfortran/caf/single.c | 278 |
3 files changed, 351 insertions, 45 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 956b43d..aa92b02 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,75 @@ +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + * caf/libcaf.h: Add mapping mode to coarray's register. + * caf/single.c (_gfortran_caf_register): Create a token sharing + another token's memory. + (check_team): Check team parameters to coindexed expressions are + valid. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + * caf/libcaf.h (_gfortran_caf_num_images): Correct prototype. + * caf/single.c (_gfortran_caf_num_images): Default + implementation. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87326 + * caf/libcaf.h (_gfortran_caf_this_image): Correct prototype. + * caf/single.c (struct caf_single_team): Add new_index of image. + (_gfortran_caf_this_image): Return the image index in the given team. + (_gfortran_caf_form_team): Set new_index in team structure. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/88154 + PR fortran/88960 + PR fortran/97210 + PR fortran/103001 + * caf/libcaf.h: Add constants for get_team's level argument and + update stat values for failed images. + (_gfortran_caf_team_number): Add prototype. + (_gfortran_caf_get_team): Same. + * caf/single.c (_gfortran_caf_team_number): Get the given team's + team number. + (_gfortran_caf_get_team): Get the current team or the team given + by level when the argument is present. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87326 + PR fortran/87556 + PR fortran/88254 + PR fortran/103796 + * caf/libcaf.h: Remove commented block. + (_gfortran_caf_form_team): Allow for all relevant arguments. + (_gfortran_caf_change_team): Same. + (_gfortran_caf_end_team): Same. + (_gfortran_caf_sync_team): Same. + * caf/single.c (struct caf_single_team): Team handling + structures. + (_gfortran_caf_init): Initialize initial team. + (free_team_list): Free all teams and the memory they hold. + (_gfortran_caf_finalize): Free initial and sibling teams. + (_gfortran_caf_register): Add memory registered to current team. + (_gfortran_caf_deregister): Unregister memory from current team. + (_gfortran_caf_is_present_on_remote): Check token's memptr for + llocation. May have been deallocated by an end team. + (_gfortran_caf_form_team): Push a new team stub to the list. + (_gfortran_caf_change_team): Push a formed team on top of the + ctive teams stack. + (_gfortran_caf_end_team): End the active team, free all memory + allocated during its livespan. + (_gfortran_caf_sync_team): Take stat and errmsg into account. + +2025-04-22 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/87939 + * caf/single.c (_gfortran_caf_lock): Correct stat value, if + lock is already locked by current image. + (_gfortran_caf_unlock): Correct stat value, if lock is not + locked. + 2025-04-13 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libfortran/119502 diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 0b371d0..7267bc7 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -31,17 +31,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include "libgfortran.h" -#if 0 -#ifndef __GNUC__ -#define __attribute__(x) -#define likely(x) (x) -#define unlikely(x) (x) -#else -#define likely(x) __builtin_expect(!!(x), 1) -#define unlikely(x) __builtin_expect(!!(x), 0) -#endif -#endif - /* Definitions of the Fortran 2008 standard; need to kept in sync with ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */ typedef enum @@ -50,14 +39,24 @@ typedef enum CAF_STAT_LOCKED, CAF_STAT_LOCKED_OTHER_IMAGE, CAF_STAT_STOPPED_IMAGE = 6000, - CAF_STAT_FAILED_IMAGE = 6001 + CAF_STAT_FAILED_IMAGE = 6001, + CAF_STAT_UNLOCKED_FAILED_IMAGE = 6002 } caf_stat_codes_t; +/* 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; /* Describes what type of array we are registerring. Keep in sync with gcc/fortran/trans.h. */ -typedef enum caf_register_t { +typedef enum caf_register_t +{ CAF_REGTYPE_COARRAY_STATIC, CAF_REGTYPE_COARRAY_ALLOC, CAF_REGTYPE_LOCK_STATIC, @@ -66,9 +65,9 @@ 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_register_t; + CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY, + CAF_REGTYPE_COARRAY_MAP_EXISTING, +} caf_register_t; /* Describes the action to take on _caf_deregister. Keep in sync with gcc/fortran/trans.h. */ @@ -78,8 +77,8 @@ typedef enum caf_deregister_t { } caf_deregister_t; -typedef void* caf_token_t; -typedef void * caf_team_t; +typedef void *caf_token_t; +typedef void *caf_team_t; typedef gfc_array_void gfc_descriptor_t; /* Linked list of static coarrays registered. */ @@ -93,8 +92,8 @@ caf_static_t; void _gfortran_caf_init (int *, char ***); void _gfortran_caf_finalize (void); -int _gfortran_caf_this_image (int); -int _gfortran_caf_num_images (int, int); +int _gfortran_caf_this_image (caf_team_t); +int _gfortran_caf_num_images (caf_team_t, int32_t *); void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *, gfc_descriptor_t *, int *, char *, size_t); @@ -185,4 +184,11 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *, void _gfortran_caf_random_init (bool, bool); +void _gfortran_caf_form_team (int, caf_team_t *, int *, int *, char *, size_t); +void _gfortran_caf_change_team (caf_team_t, int *, char *, size_t); +void _gfortran_caf_end_team (int *, char *, size_t); +void _gfortran_caf_sync_team (caf_team_t, int *, char *, size_t); +int _gfortran_caf_team_number (caf_team_t); +caf_team_t _gfortran_caf_get_team (int32_t *); + #endif /* LIBCAF_H */ diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 9c1c0c1..97876fa 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -50,6 +50,22 @@ typedef struct caf_single_token *caf_single_token_t; #define TOKEN(X) ((caf_single_token_t) (X)) #define MEMTOK(X) ((caf_single_token_t) (X))->memptr +struct caf_single_team +{ + struct caf_single_team *parent; + int team_no; + int index; + struct coarray_allocated + { + struct coarray_allocated *next; + caf_single_token_t token; + } *allocated; +}; +typedef struct caf_single_team *caf_single_team_t; +/* This points to the most current team. */ +static caf_single_team_t caf_team_stack = NULL, caf_initial_team; +static caf_single_team_t caf_teams_formed = NULL; + /* Single-image implementation of the CAF library. Note: For performance reasons -fcoarry=single should be used rather than this library. */ @@ -125,13 +141,39 @@ caf_internal_error (const char *msg, int *stat, char *errmsg, va_end (args); } +static void +init_caf_team_stack (void) +{ + caf_initial_team = caf_team_stack + = (caf_single_team_t) calloc (1, sizeof (struct caf_single_team)); + caf_initial_team->team_no = -1; +} void _gfortran_caf_init (int *argc __attribute__ ((unused)), char ***argv __attribute__ ((unused))) { + if (likely (!caf_team_stack)) + init_caf_team_stack (); } +static void +free_team_list (caf_single_team_t l) +{ + while (l != NULL) + { + caf_single_team_t p = l->parent; + struct coarray_allocated *ca = l->allocated; + while (ca) + { + struct coarray_allocated *nca = ca->next; + free (ca); + ca = nca; + } + free (l); + l = p; + } +} void _gfortran_caf_finalize (void) @@ -146,19 +188,22 @@ _gfortran_caf_finalize (void) free (caf_static_list); caf_static_list = tmp; } -} + free_team_list (caf_team_stack); + caf_initial_team = caf_team_stack = NULL; + free_team_list (caf_teams_formed); + caf_teams_formed = NULL; +} int -_gfortran_caf_this_image (int distance __attribute__ ((unused))) +_gfortran_caf_this_image (caf_team_t team) { - return 1; + return team ? ((caf_single_team_t) team)->index : 1; } - int -_gfortran_caf_num_images (int distance __attribute__ ((unused)), - int failed __attribute__ ((unused))) +_gfortran_caf_num_images (caf_team_t team __attribute__ ((unused)), + int32_t *team_number __attribute__ ((unused))) { return 1; } @@ -182,6 +227,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, local = calloc (size, sizeof (uint32_t)); else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY) local = NULL; + else if (type == CAF_REGTYPE_COARRAY_MAP_EXISTING) + local = GFC_DESCRIPTOR_DATA (data); else local = malloc (size); @@ -203,9 +250,12 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, single_token = TOKEN (*token); single_token->memptr = local; - single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY; + single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY + && type != CAF_REGTYPE_COARRAY_MAP_EXISTING; single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL; + if (unlikely (!caf_team_stack)) + init_caf_team_stack (); if (stat) *stat = 0; @@ -219,6 +269,20 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, tmp->token = *token; caf_static_list = tmp; } + else + { + struct coarray_allocated *ca = caf_team_stack->allocated; + for (; ca && ca->token != single_token; ca = ca->next) + ; + if (!ca) + { + ca = (struct coarray_allocated *) malloc ( + sizeof (struct coarray_allocated)); + *ca = (struct coarray_allocated) {caf_team_stack->allocated, + single_token}; + caf_team_stack->allocated = ca; + } + } GFC_DESCRIPTOR_DATA (data) = local; } @@ -231,10 +295,30 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, caf_single_token_t single_token = TOKEN (*token); if (single_token->owning_memory && single_token->memptr) - free (single_token->memptr); + { + free (single_token->memptr); + if (single_token->desc) + GFC_DESCRIPTOR_DATA (single_token->desc) = NULL; + } if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY) { + struct coarray_allocated *ca = caf_team_stack->allocated; + if (ca && caf_team_stack->allocated->token == single_token) + caf_team_stack->allocated = ca->next; + else + { + struct coarray_allocated *pca = NULL; + for (; ca && ca->token != single_token; pca = ca, ca = ca->next) + ; + if (!ca) + caf_runtime_error ( + "Coarray token to be freeed is not in current team %d", type); + /* Unhook found coarray_allocated node from list... */ + pca->next = ca->next; + } + /* ... and free. */ + free (ca); free (TOKEN (*token)); *token = NULL; } @@ -539,6 +623,37 @@ _gfortran_caf_get_remote_function_index (const int hash) return index; } +static bool +check_team (caf_team_t *team, int *team_number, int *stat) +{ + if (team || team_number) + { + caf_single_team_t cur = caf_team_stack; + + if (team) + { + caf_single_team_t single_team = (caf_single_team_t) (*team); + while (cur && cur != single_team) + cur = cur->parent; + } + else + while (cur && cur->team_no != *team_number) + cur = cur->parent; + + if (!cur) + { + if (stat) + { + *stat = 1; + return false; + } + else + caf_runtime_error ("requested team not found"); + } + } + return true; +} + void _gfortran_caf_get_from_remote ( caf_token_t token, const gfc_descriptor_t *opt_src_desc, @@ -547,8 +662,7 @@ _gfortran_caf_get_from_remote ( size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc, const bool may_realloc_dst, const int getter_index, void *add_data, const size_t add_data_size __attribute__ ((unused)), int *stat, - caf_team_t *team __attribute__ ((unused)), - int *team_number __attribute__ ((unused))) + caf_team_t *team, int *team_number) { caf_single_token_t single_token = TOKEN (token); void *src_ptr = opt_src_desc ? (void *) opt_src_desc : single_token->memptr; @@ -563,6 +677,9 @@ _gfortran_caf_get_from_remote ( if (stat) *stat = 0; + if (!check_team (team, team_number, stat)) + return; + if (opt_dst_desc && !may_realloc_dst) { old_dst_data_ptr = opt_dst_desc->base_addr; @@ -599,11 +716,10 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index, int32_t result; struct caf_single_token cb_token = {add_data, NULL, false}; - - accessor_hash_table[present_index].u.is_present (add_data, &image_index, - &result, - single_token->memptr, - &cb_token, 0); + accessor_hash_table[present_index].u.is_present ( + add_data, &image_index, &result, + single_token->desc ? single_token->desc : (void *) &single_token->memptr, + &cb_token, 0); return result; } @@ -616,8 +732,7 @@ _gfortran_caf_send_to_remote ( const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc, const int accessor_index, void *add_data, const size_t add_data_size __attribute__ ((unused)), int *stat, - caf_team_t *team __attribute__ ((unused)), - int *team_number __attribute__ ((unused))) + caf_team_t *team, int *team_number) { caf_single_token_t single_token = TOKEN (token); void *dst_ptr = opt_dst_desc ? (void *) opt_dst_desc : single_token->memptr; @@ -630,6 +745,9 @@ _gfortran_caf_send_to_remote ( if (stat) *stat = 0; + if (!check_team (team, team_number, stat)) + return; + accessor_hash_table[accessor_index].u.receiver (add_data, &image_index, dst_ptr, src_ptr, &cb_token, 0, opt_dst_charlen, @@ -647,10 +765,8 @@ _gfortran_caf_transfer_between_remotes ( const int src_access_index, void *src_add_data, const size_t src_add_data_size __attribute__ ((unused)), const size_t src_size, const bool scalar_transfer, int *dst_stat, - int *src_stat, caf_team_t *dst_team __attribute__ ((unused)), - int *dst_team_number __attribute__ ((unused)), - caf_team_t *src_team __attribute__ ((unused)), - int *src_team_number __attribute__ ((unused))) + int *src_stat, caf_team_t *dst_team, int *dst_team_number, + caf_team_t *src_team, int *src_team_number) { caf_single_token_t src_single_token = TOKEN (src_token), dst_single_token = TOKEN (dst_token); @@ -669,6 +785,9 @@ _gfortran_caf_transfer_between_remotes ( if (src_stat) *src_stat = 0; + if (!check_team (src_team, src_team_number, src_stat)) + return; + if (!scalar_transfer) { const size_t desc_size = sizeof (*transfer_desc); @@ -691,6 +810,9 @@ _gfortran_caf_transfer_between_remotes ( if (dst_stat) *dst_stat = 0; + if (!check_team (dst_team, dst_team_number, dst_stat)) + return; + if (scalar_transfer) transfer_ptr = *(void **) transfer_ptr; @@ -859,14 +981,14 @@ _gfortran_caf_lock (caf_token_t token, size_t index, { *acquired_lock = (int) false; if (stat) - *stat = 0; - return; + *stat = GFC_STAT_LOCKED; + return; } if (stat) { - *stat = 1; + *stat = GFC_STAT_LOCKED; if (errmsg_len > 0) { size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len @@ -899,7 +1021,7 @@ _gfortran_caf_unlock (caf_token_t token, size_t index, if (stat) { - *stat = 1; + *stat = GFC_STAT_UNLOCKED; if (errmsg_len > 0) { size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len @@ -923,3 +1045,109 @@ void _gfortran_caf_random_init (bool repeatable, bool image_distinct) routine. */ _gfortran_random_init (repeatable, image_distinct, 1); } + +void +_gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index, + int *stat, char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + const char alloc_fail_msg[] = "Failed to allocate team"; + caf_single_team_t t; + if (stat) + *stat = 0; + + *team = malloc (sizeof (struct caf_single_team)); + if (unlikely (*team == NULL)) + { + caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len); + return; + } + t = *((caf_single_team_t *) team); + t->parent = caf_teams_formed; + t->team_no = team_no; + t->index = new_index ? *new_index : 1; + t->allocated = NULL; + caf_teams_formed = t; +} + +void +_gfortran_caf_change_team (caf_team_t team, int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + caf_single_team_t t = (caf_single_team_t) team; + + if (stat) + *stat = 0; + + if (t == caf_teams_formed) + caf_teams_formed = t->parent; + else + for (caf_single_team_t p = caf_teams_formed; p; p = p->parent) + if (p->parent == t) + { + p->parent = t->parent; + break; + } + + t->parent = caf_team_stack; + caf_team_stack = t; +} + +void +_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len) +{ + caf_single_team_t t = caf_team_stack; + + if (stat) + *stat = 0; + + caf_team_stack = caf_team_stack->parent; + for (struct coarray_allocated *ca = t->allocated; ca;) + { + struct coarray_allocated *nca = ca->next; + _gfortran_caf_deregister ((caf_token_t *) &ca->token, + CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat, + errmsg, errmsg_len); + free (ca); + ca = nca; + } + t->allocated = NULL; + t->parent = caf_teams_formed; + caf_teams_formed = t; +} + +void +_gfortran_caf_sync_team (caf_team_t team __attribute__ ((unused)), int *stat, + char *errmsg __attribute__ ((unused)), + size_t errmsg_len __attribute__ ((unused))) +{ + if (stat) + *stat = 0; +} + +int +_gfortran_caf_team_number (caf_team_t team) +{ + return ((caf_single_team_t) team)->team_no; +} + +caf_team_t +_gfortran_caf_get_team (int32_t *level) +{ + if (!level) + return caf_team_stack; + + switch ((caf_team_level_t) *level) + { + case CAF_INITIAL_TEAM: + return caf_initial_team; + case CAF_PARENT_TEAM: + return caf_team_stack->parent ? caf_team_stack->parent : caf_team_stack; + case CAF_CURRENT_TEAM: + return caf_team_stack; + default: + caf_runtime_error ("Illegal value for GET_TEAM"); + } + return NULL; /* To prevent any warnings. */ +} |