diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d66c13b2661..87307c5531e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4172,5 +4172,6 @@ bool gfc_is_reallocatable_lhs (gfc_expr *); void finish_oacc_declare (gfc_namespace *, gfc_symbol *, bool); void gfc_adjust_builtins (void); +void gfc_add_caf_accessor (gfc_expr *, gfc_expr *); #endif /* GCC_GFORTRAN_H */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 2838702b64b..47b89ea726c 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4190,10 +4190,14 @@ future implementation of teams. It is about to change without further notice. * _gfortran_caf_stopped_images :: Get an array of the indexes of the stopped images * _gfortran_caf_register:: Registering coarrays * _gfortran_caf_deregister:: Deregistering coarrays +* _gfortran_caf_register_accessor:: Register an accessor for remote access +* _gfortran_caf_register_accessors_finish:: Finish registering accessor functions +* _gfortran_caf_get_remote_function_index:: Get the index of an accessor * _gfortran_caf_is_present:: Query whether an allocatable or pointer component in a derived type coarray is allocated * _gfortran_caf_send:: Sending data from a local image to a remote image * _gfortran_caf_get:: Getting data from a remote image * _gfortran_caf_sendget:: Sending data between remote images +* _gfortran_caf_get_by_ct:: Getting data from a remote image using a remote side accessor * _gfortran_caf_send_by_ref:: Sending data from a local image to a remote image using enhanced references * _gfortran_caf_get_by_ref:: Getting data from a remote image using enhanced references * _gfortran_caf_sendget_by_ref:: Sending data between remote images using enhanced references @@ -4447,8 +4451,9 @@ in the @var{DESC}'s data-ptr is registered or allocate when the data-ptr is @code{NULL}. @item @emph{Syntax}: -@code{void caf_register (size_t size, caf_register_t type, caf_token_t *token, -gfc_descriptor_t *desc, int *stat, char *errmsg, size_t errmsg_len)} +@code{void _gfortran_caf_register (size_t size, caf_register_t type, +caf_token_t *token, gfc_descriptor_t *desc, int *stat, char *errmsg, +size_t errmsg_len)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4499,7 +4504,7 @@ not null. The library is only expected to free memory it allocated itself during a call to @code{_gfortran_caf_register}. @item @emph{Syntax}: -@code{void caf_deregister (caf_token_t *token, caf_deregister_t type, +@code{void _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, char *errmsg, size_t errmsg_len)} @item @emph{Arguments}: @@ -4522,6 +4527,114 @@ and via destructors. @end table +@node _gfortran_caf_register_accessor +@subsection @code{_gfortran_caf_register_accessor} --- Register an accessor for remote access +@cindex Coarray, _gfortran_caf_register_accessor + +@table @asis +@item @emph{Description}: +Identification of access funtions across images is done using a unique hash. +For each given hash an accessor has to be registered. This routine is expected +to register an accessor function pointer for the given hash in nearly constant +time. I.e. it is expected to add the hash and accessor to a buffer and return. +Sorting shall be done in @code{_gfortran_caf_register_accessors_finish}. + +@item @emph{Syntax}: +@code{void _gfortran_caf_register_accessor (const int hash, +void (*accessor)(void **, int32_t *, void *, void *, size_t *, +size_t *))} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{hash} @tab intent(in) The unique hash value this accessor is to be +identified by. +@item @var{accessor} @tab intent(in) A pointer to the function on this image. +The function has the signature @code{void accessor (void **dst_ptr, +int32_t *free_dst, void *src_ptr, void *get_data, size_t *opt_src_charlen, +size_t *opt_dst_charlen)}. GFortran ensures that functions provided to +@code{_gfortran_caf_register_accessor} adhere to this interface. +@end multitable + +@item @emph{NOTES} +This function is required to have a nearly constant runtime complexity, because +it will be called to register multiple accessor in a sequence. GFortran ensures +that before the first remote accesses commences +@code{_gfortran_caf_register_accessors_finish} is called at least once. It is +valid to register further accessors after a call to +@code{_gfortran_caf_register_accessors_finish}. It is invalid to call +@code{_gfortran_caf_register_accessor} after the first remote access has been +done. See also @ref{_gfortran_caf_register_accessors_finish} and +@ref{_gfortran_caf_get_remote_function_index} +@end table + + +@node _gfortran_caf_register_accessors_finish +@subsection @code{_gfortran_caf_register_accessors_finish} --- Finish registering accessor functions +@cindex Coarray, _gfortran_caf_register_accessors_finish + +@table @asis +@item @emph{Description}: +Called to finalize registering of accessor functions. This function is expected +to prepare a lookup table that has fast lookup time for the hash supplied to +@code{_gfortran_caf_get_remote_function_index} and constant access time for +indexing operations. + +@item @emph{Syntax}: +@code{void _gfortran_caf_register_accessors_finish ()} + +@item @emph{Arguments}: +No arguments. + +@item @emph{NOTES} +This function may be called multiple times with and without new hash-accessors- +pairs being added. The post-condition after each call has to be, that hashes +can be looked up quickly and indexing on the lookup table of hash-accessor-pairs +is a constant time operation. +@end table + + +@node _gfortran_caf_get_remote_function_index +@subsection @code{_gfortran_caf_get_remote_function_index} --- Get the index of an accessor +@cindex Coarray, _gfortran_caf_get_remote_function_index + +@table @asis +@item @emph{Description}: +Return the index of the accessor in the lookup table build by +@ref{_gfortran_caf_register_accessor} and +@ref{_gfortran_caf_register_accessors_finish}. This function is expected to be +fast, because it may be called often. A log(N) lookup time for a given hash is +preferred. The reference implementation uses @code{bsearch ()}, for example. +The index returned shall be an array index to be used by +@ref{_gfortran_caf_get_by_ct}, i.e. a constant time operation is mandatory for +quick access. + +The GFortran compiler ensures, that +@code{_gfortran_caf_get_remote_function_index} is called once only for each +hash and the result be stored in a static variable to prevent future redundant +lookups. + +@item @emph{Syntax}: +@code{int _gfortran_caf_get_remote_function_index (const int hash)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{hash} @tab intent(in) The hash of the accessor desired. +@end multitable + +@item @emph{Result}: +The zero based index to access the accessor funtion in a lookup table. +On error, @code{-1} can be returned. + +@item @emph{NOTES} +The function's complexity is expected to be significantly smaller than N, +where N is the number of all accessors registered. Although returning @code{-1} +is valid, will this most likely crash the Fortran program when accessing the +-1-th accessor function. It is therefore advised to terminate with an error +message, when the hash could not be found. +@end table + + + @node _gfortran_caf_is_present @subsection @code{_gfortran_caf_is_present} --- Query whether an allocatable or pointer component in a derived type coarray is allocated @cindex Coarray, _gfortran_caf_is_present @@ -4850,6 +4963,81 @@ error message why the operation is not permitted. @end table +@node _gfortran_caf_get_by_ct +@subsection @code{_gfortran_caf_get_by_ct} --- Getting data from a remote image using a remote side accessor +@cindex Coarray, _gfortran_caf_get_by_ct + +@table @asis +@item @emph{Description}: +Called to get a scalar, an array section or a whole array from a remote image +identified by the @var{image_index}. + +@item @emph{Syntax}: +@code{void _gfortran_caf_get_by_ct (caf_token_t token, +const gfc_descriptor_t *opt_src_desc, const size_t *opt_src_charlen, +const int image_index, const size_t dst_size, void **dst_data, +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, int *team_number)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{token} @tab intent(in) An opaque pointer identifying the coarray. +@item @var{opt_src_desc} @tab intent(in) A pointer to the descriptor when the +object identified by @var{token} is an array with a descriptor. The parameter +needs to be set to @code{NULL}, when @var{token} identifies a scalar. +@item @var{opt_src_charlen} @tab intent(in) When the object to get is a char +array with deferred length, then this parameter needs to be set to point to its +length. Else the parameter needs to be set to @code{NULL}. +@item @var{image_index} @tab intent(in) The ID of the remote image; must be a +positive number. @code{this_image ()} is valid. +@item @var{dst_size} @tab intent(in) The size of data expected to be transferred +from the remote image. If the data type to get is a string or string array, +then this needs to be set to the byte size of each character, i.e. @code{4} for +a @code{CHARACTER (KIND=4)} string. The length of the string is then returned +in @code{opt_dst_charlen} (also for string arrays). +@item @var{dst_data} @tab intent(inout) A pointer to the adress the data is +stored. To prevent copying of data into an output buffer the adress to the live +data is returned here. When a descriptor is provided also its data-member is +set to that adress. When @var{may_realloc_dst} is set, then the memory may be +reallocated by the remote function, which needs to be replicated by this +function. +@item @var{opt_dst_charlen} @tab intent(inout) When a char array is returned, +this parameter is set to the length where applicable. The value can also be +read to prevent reallocation in the accessor. +@item @var{opt_dst_desc} @tab intent(inout) When a descriptor array is +returned, it is stored in the memory pointed to by this optional parameter. +When @var{may_realloc_dst} is set, then the descriptor may be changed, i.e. +its bounds, but upto now not its rank. +@item @var{may_realloc_dst} @tab intent(in) Set when the returned data may +require reallocation of the output buffer in @var{dst_data} or +@var{opt_dst_desc}. +@item @var{getter_index} @tab intent(in) The index of the accessor to execute +as returned by @code{_gfortran_caf_get_remote_function_index ()}. +@item @var{get_data} @tab intent(inout) Additional data needed in the accessor. +I.e., when an array reference uses a local variable @var{v}, it is transported +in this structure and all references in the accessor are rewritten to access the +member. The data in the structure of @var{get_data} may be changed by the +accessor, but these changes are lost to the calling Fortran program. +@item @var{get_data_size} @tab intent(in) The size of the @var{get_data} +structure. +@item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the +operation, i.e., zero on success and non-zero on error. When @code{NULL} and an +error occurs, then an error message is printed and the program is terminated. +@item @var{team} @tab intent(in) The opaque team handle as returned by +@code{FORM TEAM}. Unused at the moment. +@item @var{team_number} @tab intent(in) The number of the team this access is +to be part of. Unused at the moment. +@end multitable + +@item @emph{NOTES} +It is permitted to have @code{image_index} equal the current image; the memory +to get and the memory to store the data may (partially) overlap. The +implementation has to take care that it handles this case, e.g. using +@code{memmove} which handles (partially) overlapping memory. +@end table + + @node _gfortran_caf_sendget_by_ref @subsection @code{_gfortran_caf_sendget_by_ref} --- Sending data between remote images using enhanced references on both sides @cindex Coarray, _gfortran_caf_sendget_by_ref diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 06d870d80de..be81a7b1522 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5904,11 +5904,627 @@ gfc_op_rank_conformable (gfc_expr *op1, gfc_expr *op2) || op1->corank == op2->corank); } +static gfc_array_spec * +get_arrayspec_from_expr (gfc_expr *expr) +{ + gfc_array_spec *src_as, *dst_as = NULL; + gfc_ref *ref; + gfc_array_ref mod_src_ar; + int dst_rank = 0; + + if (expr->rank == 0) + return NULL; + + /* Follow any component references. */ + if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT) + { + if (expr->symtree) + src_as = expr->symtree->n.sym->as; + else + src_as = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_COMPONENT: + src_as = ref->u.c.component->as; + continue; + + case REF_SUBSTRING: + case REF_INQUIRY: + continue; + + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_ELEMENT: + src_as = NULL; + break; + case AR_SECTION: { + if (!dst_as) + dst_as = gfc_get_array_spec (); + memset (&mod_src_ar, 0, sizeof (gfc_array_ref)); + mod_src_ar = ref->u.ar; + for (int dim = 0; dim < src_as->rank; ++dim) + { + switch (ref->u.ar.dimen_type[dim]) + { + case DIMEN_ELEMENT: + gfc_free_expr (mod_src_ar.start[dim]); + mod_src_ar.start[dim] = NULL; + break; + case DIMEN_RANGE: + dst_as->lower[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + if (ref->u.ar.end[dim]) + { + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.end[dim]); + mod_src_ar.end[dst_rank] = ref->u.ar.end[dim]; + mod_src_ar.stride[dst_rank] + = ref->u.ar.stride[dim]; + } + else + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.as->upper[dim]); + ++dst_rank; + break; + case DIMEN_STAR: + dst_as->lower[dst_rank] + = gfc_copy_expr (ref->u.ar.as->lower[dim]); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + if (ref->u.ar.as->upper[dim]) + { + dst_as->upper[dst_rank] + = gfc_copy_expr (ref->u.ar.as->upper[dim]); + mod_src_ar.end[dst_rank] = ref->u.ar.end[dim]; + mod_src_ar.stride[dst_rank] + = ref->u.ar.stride[dim]; + } + ++dst_rank; + break; + case DIMEN_VECTOR: + dst_as->lower[dst_rank] + = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, + &expr->where); + mpz_set_ui (dst_as->lower[dst_rank]->value.integer, + 1); + mod_src_ar.start[dst_rank] + = gfc_copy_expr (ref->u.ar.start[dim]); + dst_as->upper[dst_rank] + = gfc_get_constant_expr (BT_INTEGER, + gfc_index_integer_kind, + &expr->where); + mpz_set (dst_as->upper[dst_rank]->value.integer, + ref->u.ar.start[dim]->shape[0]); + ++dst_rank; + break; + case DIMEN_THIS_IMAGE: + case DIMEN_UNKNOWN: + gcc_unreachable (); + } + if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT) + mod_src_ar.dimen_type[dst_rank] + = ref->u.ar.dimen_type[dim]; + } + dst_as->rank = dst_rank; + dst_as->type = AS_EXPLICIT; + ref->u.ar = mod_src_ar; + ref->u.ar.dimen = dst_rank; + break; + + case AR_UNKNOWN: + src_as = NULL; + break; + + case AR_FULL: + dst_as = gfc_copy_array_spec (src_as); + break; + } + break; + } + } + } + } + else + src_as = NULL; + + return dst_as; +} + +static void +remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns, + gfc_array_spec *src_as = NULL) +{ + gfc_symbol *derived; + gfc_symbol *src_derived = base->ts.u.derived; + + if (!src_as) + src_as = src_derived->as; + gfc_get_symbol (src_derived->name, ns, &derived); + derived->attr.flavor = FL_DERIVED; + derived->attr.alloc_comp = src_derived->attr.alloc_comp; + if (src_as && src_as->rank != 0) + { + base->attr.dimension = 1; + base->as = gfc_copy_array_spec (src_as); + base->as->corank = 0; + } + for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next) + { + gfc_component *n = gfc_get_component (); + *n = *c; + if (n->as) + n->as = gfc_copy_array_spec (c->as); + n->backend_decl = NULL; + n->initializer = NULL; + n->param_list = NULL; + if (p) + p->next = n; + else + derived->components = n; + + p = n; + } + gfc_set_sym_referenced (derived); + gfc_commit_symbol (derived); + base->ts.u.derived = derived; + gfc_commit_symbol (base); +} + +static void +convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns) +{ + gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived; + gfc_array_spec *src_as = CLASS_DATA (base)->as; + const bool attr_allocatable + = src_as && src_as->rank && src_as->type == AS_DEFERRED; + + base->ts.type = BT_DERIVED; + base->ts.u.derived = src_derived; + + remove_coarray_from_derived_type (base, ns, src_as); + + base->attr.allocatable = attr_allocatable; + base->attr.pointer = 0; // Ensure, that it is no pointer. +} + +static void +split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, + gfc_expr **post_caf_ref_expr) +{ + gfc_ref *caf_ref = NULL; + gfc_symtree *st; + gfc_symbol *base; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + if (!expr->symtree->n.sym->attr.codimension) + { + /* The coarray is in some component. Find it. */ + caf_ref = expr->ref; + while (caf_ref) + { + if (caf_ref->type == REF_COMPONENT + && caf_ref->u.c.component->attr.codimension) + break; + caf_ref = caf_ref->next; + } + } + + gcc_assert (!gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns, + &st, false)); + st->n.sym->attr.flavor = FL_PARAMETER; + st->n.sym->attr.dummy = 1; + st->n.sym->attr.intent = INTENT_IN; + st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts; + + *post_caf_ref_expr = gfc_get_variable_expr (st); + (*post_caf_ref_expr)->where = expr->where; + base = (*post_caf_ref_expr)->symtree->n.sym; + + if (!caf_ref) + { + (*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref); + if (expr->symtree->n.sym->attr.dimension) + { + base->as = gfc_copy_array_spec (expr->symtree->n.sym->as); + base->as->corank = 0; + base->attr.dimension = 1; + base->attr.allocatable = expr->symtree->n.sym->attr.allocatable; + base->attr.pointer = expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->attr.associate_var; + } + } + else + { + (*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next); + if (caf_ref->u.c.component->attr.dimension) + { + base->as = gfc_copy_array_spec (caf_ref->u.c.component->as); + base->as->corank = 0; + base->attr.dimension = 1; + base->attr.allocatable = caf_ref->u.c.component->attr.allocatable; + base->attr.pointer = caf_ref->u.c.component->attr.pointer; + } + base->ts = caf_ref->u.c.component->ts; + } + (*post_caf_ref_expr)->ts = expr->ts; + if (base->ts.type == BT_CHARACTER) + { + base->ts.u.cl = gfc_get_charlen (); + *base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl + : expr->symtree->n.sym->ts.u.cl); + base->ts.deferred = 1; + base->ts.u.cl->length = nullptr; + } + + if (base->ts.type == BT_DERIVED) + remove_coarray_from_derived_type (base, ns); + else if (base->ts.type == BT_CLASS) + convert_coarray_class_to_derived_type (base, ns); + + gfc_expression_rank (expr); + gfc_expression_rank (*post_caf_ref_expr); +} + +static void +check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *get_data) +{ + if (e) + { + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + break; + case EXPR_OP: + check_add_new_component (type, e->value.op.op1, get_data); + if (e->value.op.op2) + check_add_new_component (type, e->value.op.op2, get_data); + break; + case EXPR_COMPCALL: + for (gfc_actual_arglist *actual = e->value.compcall.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, get_data); + break; + case EXPR_FUNCTION: + if (!e->symtree->n.sym->attr.pure + && !e->symtree->n.sym->attr.elemental) + { + // Treat non-pure functions. + gfc_error ("Sorry, not yet able to call a non-pure/non-elemental" + " function %s in a coarray reference; use a temporary" + " for the function's result instead", + e->symtree->n.sym->name); + } + for (gfc_actual_arglist *actual = e->value.function.actual; actual; + actual = actual->next) + check_add_new_component (type, actual->expr, get_data); + break; + case EXPR_VARIABLE: { + gfc_component *comp; + gfc_ref *ref; + int old_rank = e->rank; + + /* Can't use gfc_find_component here, because type is not yet + complete. */ + comp = type->components; + while (comp) + { + if (strcmp (comp->name, e->symtree->name) == 0) + break; + comp = comp->next; + } + if (!comp) + { + gcc_assert (gfc_add_component (type, e->symtree->name, &comp)); + /* Take a copy of e, before modifying it. */ + gfc_expr *init = gfc_copy_expr (e); + if (e->ref) + { + switch (e->ref->type) + { + case REF_ARRAY: + comp->as = get_arrayspec_from_expr (e); + comp->attr.dimension = e->ref->u.ar.dimen != 0; + comp->ts = e->ts; + break; + case REF_COMPONENT: + comp->ts = e->ref->u.c.sym->ts; + break; + default: + gcc_unreachable (); + break; + } + } + else + comp->ts = e->ts; + comp->attr.access = ACCESS_PRIVATE; + comp->initializer = init; + } + else + gcc_assert (comp->ts.type == e->ts.type + && comp->ts.u.derived == e->ts.u.derived); + + ref = e->ref; + e->ref = NULL; + gcc_assert (gfc_find_component (get_data->ts.u.derived, + e->symtree->name, false, true, + &e->ref)); + e->symtree + = gfc_find_symtree (get_data->ns->sym_root, get_data->name); + e->ref->next = ref; + gfc_free_shape (&e->shape, old_rank); + gfc_expression_rank (e); + break; + } + case EXPR_ARRAY: + case EXPR_PPC: + case EXPR_STRUCTURE: + case EXPR_SUBSTRING: + gcc_unreachable (); + default:; + } + } +} + +static gfc_symbol * +create_get_parameter_type (gfc_expr *expr, gfc_namespace *ns, + gfc_symbol *get_data) +{ + static int type_cnt = 0; + char tname[GFC_MAX_SYMBOL_LEN + 1]; + char *name; + gfc_symbol *type; + + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + strcpy (tname, expr->symtree->name); + name = xasprintf ("@_rget_data_t_%s_%d", tname, ++type_cnt); + gfc_get_symbol (name, ns, &type); + + type->attr.flavor = FL_DERIVED; + get_data->ts.u.derived = type; + + for (gfc_ref *ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + gfc_array_ref *ar = &ref->u.ar; + for (int i = 0; i < ar->dimen; ++i) + { + check_add_new_component (type, ar->start[i], get_data); + check_add_new_component (type, ar->end[i], get_data); + check_add_new_component (type, ar->stride[i], get_data); + } + } + } + + gfc_set_sym_referenced (type); + gfc_commit_symbol (type); + return type; +} + + +static gfc_expr * +create_get_callback (gfc_expr *expr) +{ + static int cnt = 0; + gfc_namespace *ns; + gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data, + *old_buffer_data; + char tname[GFC_MAX_SYMBOL_LEN + 1]; + char *name; + const char *mname; + gfc_expr *cb, *post_caf_ref_expr; + gfc_code *code; + int expr_rank = expr->rank; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns->parent; ns = ns->parent) + ; + + if (expr->expr_type == EXPR_VARIABLE) + strcpy (tname, expr->symtree->name); + else + strcpy (tname, "dummy"); + if (expr->symtree->n.sym->module) + mname = expr->symtree->n.sym->module; + else + mname = "main"; + name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++cnt); + gfc_get_symbol (name, ns, &extproc); + gfc_set_sym_referenced (extproc); + ++extproc->refs; + gfc_commit_symbol (extproc); + + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + gfc_find_symbol (name, sub_ns, 1, &proc); + sub_ns->proc_name = proc; + proc->attr.if_source = IFSRC_DECL; + proc->attr.access = ACCESS_PUBLIC; + gfc_add_subroutine (&proc->attr, name, NULL); + proc->attr.host_assoc = 1; + proc->attr.always_explicit = 1; + ++proc->refs; + gfc_commit_symbol (proc); + free (name); + + split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr); + + if (ns->proc_name->attr.flavor == FL_MODULE) + proc->module = ns->proc_name->name; + gfc_set_sym_referenced (proc); + /* Set up formal arguments. */ + gfc_formal_arglist **argptr = &proc->formal; +#define ADD_ARG(name, nsym, stype, sintent) \ + gfc_get_symbol (name, sub_ns, &nsym); \ + nsym->ts.type = stype; \ + nsym->attr.flavor = FL_PARAMETER; \ + nsym->attr.dummy = 1; \ + nsym->attr.intent = sintent; \ + gfc_set_sym_referenced (nsym); \ + *argptr = gfc_get_formal_arglist (); \ + (*argptr)->sym = nsym; \ + argptr = &(*argptr)->next + + ADD_ARG ("buffer", buffer, expr->ts.type, INTENT_INOUT); + buffer->ts = expr->ts; + if (expr_rank) + { + buffer->as = gfc_get_array_spec (); + buffer->as->rank = expr_rank; + if (expr->shape) + { + buffer->as->type = AS_EXPLICIT; + for (int d = 0; d < expr_rank; ++d) + { + buffer->as->lower[d] + = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &gfc_current_locus); + gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1); + buffer->as->upper[d] + = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, + &gfc_current_locus); + gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer, + gfc_mpz_get_hwi (expr->shape[d])); + } + buffer->attr.allocatable = 1; + } + else + { + buffer->as->type = AS_DEFERRED; + buffer->attr.allocatable = 1; + } + buffer->attr.dimension = 1; + } + else + buffer->attr.pointer = 1; + if (buffer->ts.type == BT_CHARACTER) + { + buffer->ts.u.cl = gfc_get_charlen (); + *buffer->ts.u.cl = *expr->ts.u.cl; + buffer->ts.deferred = 1; + buffer->ts.u.cl->length = nullptr; + } + gfc_commit_symbol (buffer); + ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, INTENT_OUT); + free_buffer->ts.kind = gfc_default_logical_kind; + gfc_commit_symbol (free_buffer); + + // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); + base = post_caf_ref_expr->symtree->n.sym; + gfc_set_sym_referenced (base); + gfc_commit_symbol (base); + *argptr = gfc_get_formal_arglist (); + (*argptr)->sym = base; + argptr = &(*argptr)->next; + + gfc_commit_symbol (base); + ADD_ARG ("get_data", get_data, BT_DERIVED, INTENT_IN); + gfc_commit_symbol (get_data); +#undef ADD_ARG + + /* Set up code. */ + if (expr->rank != 0) + { + /* Code: old_buffer_ptr = C_LOC (buffer); */ + code = sub_ns->code = gfc_get_code (EXEC_ASSIGN); + gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data); + old_buffer_data->ts.type = BT_VOID; + old_buffer_data->attr.flavor = FL_VARIABLE; + gfc_set_sym_referenced (old_buffer_data); + gfc_commit_symbol (old_buffer_data); + code->expr1 = gfc_lval_expr_from_sym (old_buffer_data); + code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, + gfc_lval_expr_from_sym (buffer)); + code->next = gfc_get_code (EXEC_ASSIGN); + code = code->next; + } + else + code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN); + + /* Code: buffer = expr; */ + code->expr1 = gfc_lval_expr_from_sym (buffer); + code->expr2 = post_caf_ref_expr; + gfc_ref *ref = code->expr2->ref, **pref = &code->expr2->ref; + if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + if (ref->u.ar.dimen != 0) + { + ref->u.ar.codimen = 0; + pref = &ref->next; + ref = ref->next; + } + else + { + code->expr2->ref = ref->next; + ref->next = NULL; + gfc_free_ref_list (ref); + ref = code->expr2->ref; + pref = &code->expr2->ref; + } + } + if (ref && ref->type == REF_COMPONENT) + { + gfc_find_component (code->expr2->symtree->n.sym->ts.u.derived, + ref->u.c.component->name, false, false, pref); + if (*pref != ref) + { + (*pref)->next = ref->next; + ref->next = NULL; + gfc_free_ref_list (ref); + } + } + get_data->ts.u.derived + = create_get_parameter_type (code->expr2, ns, get_data); + if (code->expr2->rank == 0) + code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, code->expr2); + + /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or + * *free_buffer = 0; for rank == 0. */ + code->next = gfc_get_code (EXEC_ASSIGN); + code = code->next; + code->expr1 = gfc_lval_expr_from_sym (free_buffer); + if (expr->rank != 0) + { + code->expr2 = gfc_get_operator_expr ( + &gfc_current_locus, INTRINSIC_NE_OS, + gfc_lval_expr_from_sym (old_buffer_data), + gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", + gfc_current_locus, 1, + gfc_lval_expr_from_sym (buffer))); + code->expr2->ts.type = BT_LOGICAL; + code->expr2->ts.kind = gfc_default_logical_kind; + } + else + { + code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, false); + } + + cb = gfc_lval_expr_from_sym (extproc); + cb->ts.interface = extproc; + + return cb; +} static void add_caf_get_intrinsic (gfc_expr *e) { - gfc_expr *wrapper, *tmp_expr; + gfc_expr *wrapper, *tmp_expr, *rget_expr, *rget_hash_expr; gfc_ref *ref; int n; @@ -5924,8 +6540,18 @@ add_caf_get_intrinsic (gfc_expr *e) tmp_expr = XCNEW (gfc_expr); *tmp_expr = *e; + rget_expr = create_get_callback (tmp_expr); + rget_hash_expr = gfc_get_expr (); + rget_hash_expr->expr_type = EXPR_CONSTANT; + rget_hash_expr->ts.type = BT_INTEGER; + rget_hash_expr->ts.kind = gfc_default_integer_kind; + rget_hash_expr->where = tmp_expr->where; + mpz_init_set_ui (rget_hash_expr->value.integer, + gfc_hash_value (rget_expr->symtree->n.sym)); wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, - "caf_get", tmp_expr->where, 1, tmp_expr); + "caf_get", tmp_expr->where, 3, tmp_expr, + rget_hash_expr, rget_expr); + gfc_add_caf_accessor (rget_hash_expr, rget_expr); wrapper->ts = e->ts; wrapper->rank = e->rank; wrapper->corank = e->corank; @@ -13052,22 +13678,10 @@ start: if (flag_coarray == GFC_FCOARRAY_LIB && (gfc_is_coindexed (code->expr1) - || caf_possible_reallocate (code->expr1) - || (code->expr2->expr_type == EXPR_FUNCTION - && code->expr2->value.function.isym - && code->expr2->value.function.isym->id - == GFC_ISYM_CAF_GET - && (code->expr1->rank == 0 || code->expr2->rank != 0) - && !gfc_expr_attr (code->expr2).allocatable - && !gfc_has_vector_subscript (code->expr2)))) + || caf_possible_reallocate (code->expr1))) { /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a - coindexed variable. Additionally, insert this code when the - RHS is a CAF as we then use the GFC_ISYM_CAF_SEND intrinsic - just to avoid a temporary; but do not do so if the LHS is - (re)allocatable or has a vector subscript. If the LHS is a - noncoindexed array and the RHS is a coindexed scalar, use the - normal code path. */ + coindexed variable. */ code->op = EXEC_CALL; gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index d69c8430484..0b1474d7559 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -84,7 +84,7 @@ static struct module_htab_entry *cur_module; /* With -fcoarray=lib: For generating the registering call of static coarrays. */ -static bool has_coarray_vars; +static bool has_coarray_vars_or_accessors; static stmtblock_t caf_init_block; @@ -135,12 +135,21 @@ tree gfor_fndecl_caf_this_image; tree gfor_fndecl_caf_num_images; tree gfor_fndecl_caf_register; tree gfor_fndecl_caf_deregister; + +// Deprecate start tree gfor_fndecl_caf_get; tree gfor_fndecl_caf_send; tree gfor_fndecl_caf_sendget; tree gfor_fndecl_caf_get_by_ref; tree gfor_fndecl_caf_send_by_ref; tree gfor_fndecl_caf_sendget_by_ref; +// Deprecate end + +tree gfor_fndecl_caf_register_accessor; +tree gfor_fndecl_caf_register_accessors_finish; +tree gfor_fndecl_caf_get_remote_function_index; +tree gfor_fndecl_caf_get_by_ct; + tree gfor_fndecl_caf_sync_all; tree gfor_fndecl_caf_sync_memory; tree gfor_fndecl_caf_sync_images; @@ -3982,11 +3991,12 @@ gfc_build_builtin_function_decls (void) /* Coarray library calls. */ if (flag_coarray == GFC_FCOARRAY_LIB) { - tree pint_type, pppchar_type; + tree pint_type, pppchar_type, psize_type; pint_type = build_pointer_type (integer_type_node); pppchar_type = build_pointer_type (build_pointer_type (pchar_type_node)); + psize_type = build_pointer_type (size_type_node); gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_init")), ". W W ", @@ -4015,6 +4025,7 @@ gfc_build_builtin_function_decls (void) ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, size_type_node); + // Deprecate start gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ", void_type_node, 10, @@ -4058,6 +4069,30 @@ gfc_build_builtin_function_decls (void) pvoid_type_node, integer_type_node, integer_type_node, boolean_type_node, pint_type, pint_type, integer_type_node, integer_type_node); + // Deprecate end + + gfor_fndecl_caf_register_accessor + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_register_accessor")), ". r r ", + void_type_node, 2, integer_type_node, pvoid_type_node); + + gfor_fndecl_caf_register_accessors_finish + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_register_accessors_finish")), ". ", + void_type_node, 0); + + gfor_fndecl_caf_get_remote_function_index + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_get_remote_function_index")), ". r ", + integer_type_node, 1, integer_type_node); + + gfor_fndecl_caf_get_by_ct = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_get_by_ct")), + ". r r r r r w w w r r w r w r r ", void_type_node, 15, pvoid_type_node, + pvoid_type_node, psize_type, integer_type_node, size_type_node, + ppvoid_type_node, psize_type, pvoid_type_node, boolean_type_node, + integer_type_node, pvoid_type_node, size_type_node, pint_type, + pvoid_type_node, pint_type); gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node, @@ -5554,7 +5589,7 @@ gfc_create_module_variable (gfc_symbol * sym) if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable && sym->attr.referenced && !sym->attr.use_assoc) - has_coarray_vars = true; + has_coarray_vars_or_accessors = true; } /* Emit debug information for USE statements. */ @@ -5937,6 +5972,49 @@ generate_coarray_sym_init (gfc_symbol *sym) } } +struct caf_accessor +{ + struct caf_accessor *next; + gfc_expr *hash, *fdecl; +}; + +static struct caf_accessor *caf_accessor_head = NULL; + +void +gfc_add_caf_accessor (gfc_expr *h, gfc_expr *f) +{ + struct caf_accessor *n = XCNEW (struct caf_accessor); + n->next = caf_accessor_head; + n->hash = h; + n->fdecl = f; + caf_accessor_head = n; +} + +void +create_caf_accessor_register (stmtblock_t *block) +{ + gfc_se se; + tree hash, fdecl; + gfc_init_se (&se, NULL); + for (struct caf_accessor *curr = caf_accessor_head; curr;) + { + gfc_conv_expr (&se, curr->hash); + hash = se.expr; + gfc_conv_expr (&se, curr->fdecl); + fdecl = se.expr; + TREE_USED (fdecl) = 1; + TREE_STATIC (fdecl) = 1; + gcc_assert (FUNCTION_POINTER_TYPE_P (TREE_TYPE (fdecl))); + gfc_add_expr_to_block ( + block, build_call_expr (gfor_fndecl_caf_register_accessor, 2, hash, + /*gfc_build_addr_expr (NULL_TREE,*/ fdecl)); + curr = curr->next; + free (caf_accessor_head); + caf_accessor_head = curr; + } + gfc_add_expr_to_block ( + block, build_call_expr (gfor_fndecl_caf_register_accessors_finish, 0)); +} /* Generate constructor function to initialize static, nonallocatable coarrays. */ @@ -5973,6 +6051,8 @@ generate_coarray_init (gfc_namespace *ns) pushlevel (); gfc_init_block (&caf_init_block); + create_caf_accessor_register (&caf_init_block); + gfc_traverse_ns (ns, generate_coarray_sym_init); DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block); @@ -6028,13 +6108,13 @@ gfc_generate_module_vars (gfc_namespace * ns) /* Generate COMMON blocks. */ gfc_trans_common (ns); - has_coarray_vars = false; + has_coarray_vars_or_accessors = caf_accessor_head != NULL; /* Create decls for all the module variables. */ gfc_traverse_ns (ns, gfc_create_module_variable); gfc_traverse_ns (ns, create_module_nml_decl); - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) generate_coarray_init (ns); cur_module = NULL; @@ -6135,7 +6215,7 @@ generate_local_decl (gfc_symbol * sym) { if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable && sym->attr.referenced && !sym->attr.use_assoc) - has_coarray_vars = true; + has_coarray_vars_or_accessors = true; if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master) generate_dependency_declarations (sym); @@ -7889,10 +7969,10 @@ gfc_generate_function_code (gfc_namespace * ns) gfc_generate_contained_functions (ns); - has_coarray_vars = false; + has_coarray_vars_or_accessors = caf_accessor_head != NULL; generate_local_vars (ns); - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) generate_coarray_init (ns); /* Keep the parent fake result declaration in module functions @@ -8113,7 +8193,7 @@ gfc_generate_function_code (gfc_namespace * ns) If there are static coarrays in this function, the nested _caf_init function has already called cgraph_create_node, which also created the cgraph node for this function. */ - if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB) + if (!has_coarray_vars_or_accessors || flag_coarray != GFC_FCOARRAY_LIB) (void) cgraph_node::get_create (fndecl); } else @@ -8240,11 +8320,11 @@ gfc_process_block_locals (gfc_namespace* ns) tree decl; saved_local_decls = NULL_TREE; - has_coarray_vars = false; + has_coarray_vars_or_accessors = caf_accessor_head != NULL; generate_local_vars (ns); - if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) + if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors) generate_coarray_init (ns); decl = nreverse (saved_local_decls); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 41a1739080e..66da97bc6e3 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "dependency.h" /* For CAF array alias analysis. */ #include "attribs.h" #include "realmpfr.h" +#include "constructor.h" /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ @@ -1667,31 +1668,59 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr) : NULL_TREE; } +static tree +conv_shape_to_cst (gfc_expr *e) +{ + tree tmp = NULL; + for (int d = 0; d < e->rank; ++d) + { + if (!tmp) + tmp = gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind); + else + tmp = fold_build2 (MULT_EXPR, TREE_TYPE (tmp), tmp, + gfc_conv_mpz_to_tree (e->shape[d], gfc_size_kind)); + } + return fold_convert (size_type_node, tmp); +} + /* Get data from a remote coarray. */ static void -gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, - tree may_require_tmp, bool may_realloc, - symbol_attribute *caf_attr) +gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, + bool may_realloc, symbol_attribute *caf_attr) { + static int call_cnt = 0; gfc_expr *array_expr, *tmp_stat; gfc_se argse; - tree caf_decl, token, offset, image_index, tmp; - tree res_var, dst_var, type, kind, vec, stat; - tree caf_reference; + tree caf_decl, token, image_index, tmp, res_var, type, stat, dest_size, + dest_data, opt_dest_desc, rget_index_tree, rget_data_tree, rget_data_size, + opt_src_desc, opt_src_charlen, opt_dest_charlen; symbol_attribute caf_attr_store; + gfc_namespace *ns; + gfc_expr *rget_hash = expr->value.function.actual->next->expr, + *rget_fn_expr = expr->value.function.actual->next->next->expr; + gfc_symbol *gdata_sym + = rget_fn_expr->symtree->n.sym->formal->next->next->next->sym; + gfc_expr rget_data, rget_data_init, rget_index; + char *name; + gfc_symtree *data_st, *index_st; + gfc_constructor *con; + stmtblock_t blk; gcc_assert (flag_coarray == GFC_FCOARRAY_LIB); if (se->ss && se->ss->info->useflags) { - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - return; + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + return; } - /* If lhs is set, the CAF_GET intrinsic has already been stripped. */ - array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr; + array_expr = expr->value.function.actual->expr; + ns = array_expr->expr_type == EXPR_VARIABLE + && !array_expr->symtree->n.sym->attr.associate_var + ? array_expr->symtree->n.sym->ns + : gfc_current_ns; type = gfc_typenode_for_spec (&array_expr->ts); if (caf_attr == NULL) @@ -1701,9 +1730,7 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, } res_var = lhs; - dst_var = lhs; - vec = null_pointer_node; tmp_stat = gfc_find_stat_co (expr); if (tmp_stat) @@ -1718,198 +1745,172 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, else stat = null_pointer_node; - /* Only use the new get_by_ref () where it is necessary. I.e., when the lhs - is reallocatable or the right-hand side has allocatable components. */ - if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc) + memset (&rget_data, 0, sizeof (gfc_expr)); + gfc_clear_ts (&rget_data.ts); + rget_data.expr_type = EXPR_VARIABLE; + name = xasprintf ("__caf_rget_data_%d", call_cnt); + gcc_assert (!gfc_get_sym_tree (name, ns, &data_st, false)); + name = xasprintf ("__caf_rget_index_%d", call_cnt); + ++call_cnt; + gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false)); + free (name); + data_st->n.sym->attr.flavor = FL_VARIABLE; + data_st->n.sym->ts = gdata_sym->ts; + rget_data.symtree = data_st; + gfc_set_sym_referenced (rget_data.symtree->n.sym); + rget_data.ts = data_st->n.sym->ts; + gfc_commit_symbol (data_st->n.sym); + + memset (&rget_data_init, 0, sizeof (gfc_expr)); + gfc_clear_ts (&rget_data_init.ts); + rget_data_init.expr_type = EXPR_STRUCTURE; + rget_data_init.ts = rget_data.ts; + for (gfc_component *comp = rget_data.ts.u.derived->components; comp; + comp = comp->next) { - /* Get using caf_get_by_ref. */ - caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr); - - if (caf_reference != NULL_TREE) - { - if (lhs == NULL_TREE) - { - if (array_expr->ts.type == BT_CHARACTER) - gfc_init_se (&argse, NULL); - if (array_expr->rank == 0) - { - symbol_attribute attr; - gfc_clear_attr (&attr); - if (array_expr->ts.type == BT_CHARACTER) - { - res_var = gfc_conv_string_tmp (se, - build_pointer_type (type), - array_expr->ts.u.cl->backend_decl); - argse.string_length = array_expr->ts.u.cl->backend_decl; - } - else - res_var = gfc_create_var (type, "caf_res"); - dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr); - dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); - } - else - { - /* Create temporary. */ - if (array_expr->ts.type == BT_CHARACTER) - gfc_conv_expr_descriptor (&argse, array_expr); - may_realloc = gfc_trans_create_temp_array (&se->pre, - &se->post, - se->ss, type, - NULL_TREE, false, - false, false, - &array_expr->where) - == NULL_TREE; - res_var = se->ss->info->data.array.descriptor; - dst_var = gfc_build_addr_expr (NULL_TREE, res_var); - if (may_realloc) - { - tmp = gfc_conv_descriptor_data_get (res_var); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, - NULL_TREE, NULL_TREE, - NULL_TREE, true, - NULL, - GFC_CAF_COARRAY_NOCOARRAY); - gfc_add_expr_to_block (&se->post, tmp); - } - } - } - - kind = build_int_cst (integer_type_node, expr->ts.kind); - if (lhs_kind == NULL_TREE) - lhs_kind = kind; - - caf_decl = gfc_get_tree_for_caf_expr (array_expr); - if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) - caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&se->pre, array_expr, - caf_decl); - gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, - array_expr); - - /* No overlap possible as we have generated a temporary. */ - if (lhs == NULL_TREE) - may_require_tmp = boolean_false_node; - - /* It guarantees memory consistency within the same segment. */ - tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), NULL_TREE, - NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; - gfc_add_expr_to_block (&se->pre, tmp); - - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref, - 10, token, image_index, dst_var, - caf_reference, lhs_kind, kind, - may_require_tmp, - may_realloc ? boolean_true_node : - boolean_false_node, - stat, build_int_cst (integer_type_node, - array_expr->ts.type)); - - gfc_add_expr_to_block (&se->pre, tmp); - - if (se->ss) - gfc_advance_se_ss_chain (se); - - se->expr = res_var; - if (array_expr->ts.type == BT_CHARACTER) - se->string_length = argse.string_length; - - return; - } + con = gfc_constructor_get (); + con->expr = comp->initializer; + comp->initializer = NULL; + gfc_constructor_append (&rget_data_init.value.constructor, con); } + index_st->n.sym->attr.flavor = FL_VARIABLE; + index_st->n.sym->attr.save = SAVE_EXPLICIT; + index_st->n.sym->value + = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, + &gfc_current_locus); + mpz_init_set_si (index_st->n.sym->value->value.integer, -1); + index_st->n.sym->ts.type = BT_INTEGER; + index_st->n.sym->ts.kind = gfc_default_integer_kind; + gfc_set_sym_referenced (index_st->n.sym); + memset (&rget_index, 0, sizeof (gfc_expr)); + gfc_clear_ts (&rget_index.ts); + rget_index.expr_type = EXPR_VARIABLE; + rget_index.symtree = index_st; + rget_index.ts = index_st->n.sym->ts; + gfc_commit_symbol (index_st->n.sym); + gfc_init_se (&argse, NULL); - if (array_expr->rank == 0) + gfc_conv_expr (&argse, &rget_index); + gfc_add_block_to_block (&se->pre, &argse.pre); + rget_index_tree = argse.expr; + + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, rget_hash); + + gfc_init_block (&blk); + tmp = build_call_expr (gfor_fndecl_caf_get_remote_function_index, 1, + argse.expr); + + gfc_add_modify (&blk, rget_index_tree, tmp); + gfc_add_expr_to_block ( + &se->pre, + build3 (COND_EXPR, void_type_node, + gfc_likely (build2 (EQ_EXPR, logical_type_node, rget_index_tree, + build_int_cst (integer_type_node, -1)), + PRED_FIRST_MATCH), + gfc_finish_block (&blk), NULL_TREE)); + + if (rget_data.ts.u.derived->components) { - symbol_attribute attr; - - gfc_clear_attr (&attr); - gfc_conv_expr (&argse, array_expr); - - if (lhs == NULL_TREE) - { - gfc_clear_attr (&attr); - if (array_expr->ts.type == BT_CHARACTER) - res_var = gfc_conv_string_tmp (se, build_pointer_type (type), - argse.string_length); - else - res_var = gfc_create_var (type, "caf_res"); - dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr); - dst_var = gfc_build_addr_expr (NULL_TREE, dst_var); - } - argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr); - argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, &rget_data); + rget_data_tree = argse.expr; + gfc_add_expr_to_block (&se->pre, + gfc_trans_structure_assign (rget_data_tree, + &rget_data_init, true, + false)); + gfc_constructor_free (rget_data_init.value.constructor); + rget_data_size = TREE_TYPE (rget_data_tree)->type_common.size_unit; + rget_data_tree = gfc_build_addr_expr (pvoid_type_node, rget_data_tree); } else { - /* If has_vector, pass descriptor for whole array and the - vector bounds separately. */ - gfc_array_ref *ar, ar2; - bool has_vector = false; - - if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr)) - { - has_vector = true; - ar = gfc_find_array_ref (expr); - ar2 = *ar; - memset (ar, '\0', sizeof (*ar)); - ar->as = ar2.as; - ar->type = AR_FULL; - } - // TODO: Check whether argse.want_coarray = 1 can help with the below. - gfc_conv_expr_descriptor (&argse, array_expr); - /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that - has the wrong type if component references are done. */ - gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), - gfc_get_dtype_rank_type (has_vector ? ar2.dimen - : array_expr->rank, - type)); - if (has_vector) - { - vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2); - *ar = ar2; - } - - if (lhs == NULL_TREE) - { - /* Create temporary. */ - for (int n = 0; n < se->ss->loop->dimen; n++) - if (se->loop->to[n] == NULL_TREE) - { - se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr, - gfc_rank_cst[n]); - se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr, - gfc_rank_cst[n]); - } - gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type, - NULL_TREE, false, true, false, - &array_expr->where); - res_var = se->ss->info->data.array.descriptor; - dst_var = gfc_build_addr_expr (NULL_TREE, res_var); - } - argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr); + rget_data_tree = build_zero_cst (pvoid_type_node); + rget_data_size = build_zero_cst (size_type_node); } - kind = build_int_cst (integer_type_node, expr->ts.kind); - if (lhs_kind == NULL_TREE) - lhs_kind = kind; - - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); + if (array_expr->rank == 0) + { + res_var = gfc_create_var (type, "caf_res"); + if (array_expr->ts.type == BT_CHARACTER) + { + gfc_conv_string_length (array_expr->ts.u.cl, array_expr, &se->pre); + argse.string_length = array_expr->ts.u.cl->backend_decl; + opt_src_charlen = gfc_build_addr_expr ( + NULL_TREE, gfc_trans_force_lval (&se->pre, argse.string_length)); + dest_size = build_int_cstu (size_type_node, array_expr->ts.kind); + } + else + { + dest_size = res_var->typed.type->type_common.size_unit; + opt_src_charlen + = build_zero_cst (build_pointer_type (size_type_node)); + } + dest_data + = gfc_evaluate_now (gfc_build_addr_expr (NULL_TREE, res_var), &se->pre); + res_var = build_fold_indirect_ref (dest_data); + dest_data = gfc_build_addr_expr (pvoid_type_node, dest_data); + opt_dest_desc = build_zero_cst (pvoid_type_node); + } + else + { + /* Create temporary. */ + may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, + type, NULL_TREE, false, false, + false, &array_expr->where) + == NULL_TREE; + res_var = se->ss->info->data.array.descriptor; + if (array_expr->ts.type == BT_CHARACTER) + { + argse.string_length = array_expr->ts.u.cl->backend_decl; + opt_src_charlen = gfc_build_addr_expr ( + NULL_TREE, gfc_trans_force_lval (&se->pre, argse.string_length)); + dest_size = build_int_cstu (size_type_node, array_expr->ts.kind); + } + else + { + opt_src_charlen + = build_zero_cst (build_pointer_type (size_type_node)); + dest_size = fold_build2 ( + MULT_EXPR, size_type_node, + fold_convert (size_type_node, + array_expr->shape + ? conv_shape_to_cst (array_expr) + : gfc_conv_descriptor_size (res_var, + array_expr->rank)), + fold_convert (size_type_node, + gfc_conv_descriptor_span_get (res_var))); + } + opt_dest_desc = res_var; + dest_data = gfc_conv_descriptor_data_get (res_var); + opt_dest_desc = gfc_build_addr_expr (NULL_TREE, opt_dest_desc); + if (may_realloc) + { + tmp = gfc_conv_descriptor_data_get (res_var); + tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, NULL, + GFC_CAF_COARRAY_NOCOARRAY); + gfc_add_expr_to_block (&se->post, tmp); + } + dest_data + = gfc_build_addr_expr (NULL_TREE, + gfc_trans_force_lval (&se->pre, dest_data)); + } + opt_dest_charlen = opt_src_charlen; caf_decl = gfc_get_tree_for_caf_expr (array_expr); - if (POINTER_TYPE_P (TREE_TYPE (caf_decl))) + if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE) caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); - image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); - gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr, - array_expr); - /* No overlap possible as we have generated a temporary. */ - if (lhs == NULL_TREE) - may_require_tmp = boolean_false_node; + if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank + || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))) + opt_src_desc = build_zero_cst (pvoid_type_node); + else + opt_src_desc = gfc_build_addr_expr (pvoid_type_node, caf_decl); + + image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl); + gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, array_expr); /* It guarantees memory consistency within the same segment. */ tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"); @@ -1919,9 +1920,12 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&se->pre, tmp); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10, - token, offset, image_index, argse.expr, vec, - dst_var, kind, lhs_kind, may_require_tmp, stat); + tmp = build_call_expr_loc ( + input_location, gfor_fndecl_caf_get_by_ct, 15, token, opt_src_desc, + opt_src_charlen, image_index, dest_size, dest_data, opt_dest_charlen, + opt_dest_desc, constant_boolean_node (may_realloc, boolean_type_node), + rget_index_tree, rget_data_tree, rget_data_size, stat, null_pointer_node, + null_pointer_node); gfc_add_expr_to_block (&se->pre, tmp); @@ -1931,6 +1935,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, se->expr = res_var; if (array_expr->ts.type == BT_CHARACTER) se->string_length = argse.string_length; + + return; } static bool @@ -1995,8 +2001,9 @@ conv_caf_send (gfc_code *code) { gfc_clear_attr (&attr); gfc_conv_expr (&lhs_se, lhs_expr); lhs_type = TREE_TYPE (lhs_se.expr); - lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, - attr); + if (lhs_is_coindexed) + lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, + attr); lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); } } @@ -2174,17 +2181,13 @@ conv_caf_send (gfc_code *code) { lhs_may_realloc = lhs_may_realloc && gfc_full_array_ref_p (lhs_expr->ref, NULL); gfc_add_block_to_block (&block, &lhs_se.pre); - gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind, - may_require_tmp, lhs_may_realloc, - &rhs_caf_attr); + gfc_conv_intrinsic_caf_get (&rhs_se, code->ext.actual->next->expr, + lhs_se.expr, lhs_may_realloc, &rhs_caf_attr); gfc_add_block_to_block (&block, &rhs_se.pre); gfc_add_block_to_block (&block, &rhs_se.post); gfc_add_block_to_block (&block, &lhs_se.post); return gfc_finish_block (&block); } - else if (rhs_expr->expr_type == EXPR_FUNCTION - && rhs_expr->value.function.isym->id == GFC_ISYM_CAF_GET) - rhs_expr = rhs_expr->value.function.actual->expr; gfc_add_block_to_block (&block, &lhs_se.pre); @@ -2301,8 +2304,8 @@ conv_caf_send (gfc_code *code) { { tree reference, dst_realloc; reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); - dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node - : boolean_false_node; + dst_realloc + = lhs_caf_attr.allocatable ? boolean_true_node : boolean_false_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_by_ref, 10, token, image_index, rhs_se.expr, @@ -2310,7 +2313,7 @@ conv_caf_send (gfc_code *code) { may_require_tmp, dst_realloc, src_stat, build_int_cst (integer_type_node, lhs_expr->ts.type)); - } + } else tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, token, offset, image_index, lhs_se.expr, vec, @@ -11290,8 +11293,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_CAF_GET: - gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE, - false, NULL); + gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL); break; case GFC_ISYM_CMPLX: diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 604cb53f417..caf95d65340 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -241,6 +241,16 @@ gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) gfc_add_modify_loc (input_location, pblock, lhs, rhs); } +tree +gfc_trans_force_lval (stmtblock_t *pblock, tree e) +{ + if (VAR_P (e)) + return e; + + tree v = gfc_create_var (TREE_TYPE (e), NULL); + gfc_add_modify (pblock, v, e); + return v; +} /* Create a new scope/binding level and initialize a block. Care must be taken when translating expressions as any temporaries will be placed in diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 4679ea0d6e1..608e8e5132c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -493,6 +493,8 @@ void gfc_init_se (gfc_se *, gfc_se *); tree gfc_create_var (tree, const char *); /* Like above but doesn't add it to the current scope. */ tree gfc_create_var_np (tree, const char *); +/* Ensure that tree can be used as an lvalue. */ +tree gfc_trans_force_lval (stmtblock_t *, tree); /* Store the result of an expression in a temp variable so it can be used repeatedly even if the original changes */ @@ -881,12 +883,21 @@ extern GTY(()) tree gfor_fndecl_caf_this_image; extern GTY(()) tree gfor_fndecl_caf_num_images; extern GTY(()) tree gfor_fndecl_caf_register; extern GTY(()) tree gfor_fndecl_caf_deregister; + +// Deprecate start extern GTY(()) tree gfor_fndecl_caf_get; extern GTY(()) tree gfor_fndecl_caf_send; extern GTY(()) tree gfor_fndecl_caf_sendget; extern GTY(()) tree gfor_fndecl_caf_get_by_ref; extern GTY(()) tree gfor_fndecl_caf_send_by_ref; extern GTY(()) tree gfor_fndecl_caf_sendget_by_ref; +// Deprecate end + +extern GTY (()) tree gfor_fndecl_caf_register_accessor; +extern GTY (()) tree gfor_fndecl_caf_register_accessors_finish; +extern GTY (()) tree gfor_fndecl_caf_get_remote_function_index; +extern GTY (()) tree gfor_fndecl_caf_get_by_ct; + extern GTY(()) tree gfor_fndecl_caf_sync_all; extern GTY(()) tree gfor_fndecl_caf_sync_memory; extern GTY(()) tree gfor_fndecl_caf_sync_images; diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 index 005f3e5eae8..70c3d2ff4eb 100644 --- a/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_5.f90 @@ -20,6 +20,6 @@ program atomic end program ! { dg-final { scan-tree-dump-times "value.. = 0;" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_define \\(caf_token.0, 0, 1, &value.., 0B, 1, 4\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_op \\(1, caf_token.0, 0, 1, &me, 0B, 0B, 1, 4\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_ref \\(caf_token.0, 0, 1, &me, 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_define \\(caf_token.., 0, 1, &value.., 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_op \\(1, caf_token.., 0, 1, &me, 0B, 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_ref \\(caf_token.., 0, 1, &me, 0B, 1, 4\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 index a8954e7afa3..68aa47ecd32 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_comm_1.f90 @@ -38,7 +38,6 @@ B(1:5) = B(3:7) if (any (A-B /= 0)) STOP 4 end -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 3 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ct \\\(caf_token.., 0B, 0B, 1, \\\(unsigned long\\\) atmp.\[0-9\]+.span" 4 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.., \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.., \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 index c29687efbe2..4d85b6ca852 100644 --- a/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_stat_function.f90 @@ -40,6 +40,6 @@ contains end program function_stat -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ct \\\(caf_token.., 0B, 0B, 4, 4, \\\(void \\\*\\\) &D....., 0B, 0B, 0, __caf_rget_index_., 0B, 0, &stat, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ct \\\(caf_token.., 0B, 0B, 1, 4, \\\(void \\\*\\\) &D....., 0B, 0B, 0, __caf_rget_index_., 0B, 0, &stat2, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_by_ct \\\(caf_token.., 0B, 0B, 3, 4, \\\(void \\\*\\\) &D....., 0B, 0B, 0, __caf_rget_index_., 0B, 0, &stat, 0B, 0B\\\);" 1 "original" } } diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index dde0469c89a..552d1afde5f 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -237,6 +237,24 @@ void _gfortran_caf_sendget_by_ref ( int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, int *src_stat, int dst_type, int src_type); +void _gfortran_caf_register_accessor (const int hash, + void (*accessor) (void **, int32_t *, + void *, void *, + const size_t *, + size_t *)); + +void _gfortran_caf_register_accessors_finish (void); + +int _gfortran_caf_get_remote_function_index (const int hash); + +void _gfortran_caf_get_by_ct ( + caf_token_t token, const gfc_descriptor_t *opt_src_desc, + const size_t *opt_src_charlen, const int image_index, + const size_t dst_size, void **dst_data, 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, int *team_number); + void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *, int, int); void _gfortran_caf_atomic_ref (caf_token_t, size_t, int, void *, int *, diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 0ffbffa1d2b..f5414ff1f7e 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -57,6 +57,25 @@ typedef struct caf_single_token *caf_single_token_t; /* Global variables. */ caf_static_t *caf_static_list = NULL; +typedef void (*accessor_t) (void **, int32_t *, void *, void *, const size_t *, + size_t *); +struct accessor_hash_t +{ + int hash; + int pad; + accessor_t accessor; +}; + +static struct accessor_hash_t *accessor_hash_table = NULL; +static int aht_cap = 0; +static int aht_size = 0; +static enum { + AHT_UNINITIALIZED, + AHT_OPEN, + AHT_PREPARED +} accessor_hash_table_state + = AHT_UNINITIALIZED; + /* Keep in sync with mpi.c. */ static void caf_runtime_error (const char *message, ...) @@ -1082,11 +1101,11 @@ _gfortran_caf_send (caf_token_t token, size_t offset, - dest->dim[j].lower_bound + 1)) * dest->dim[j]._stride; extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1); - stride = dest->dim[j]._stride; + stride = dest->dim[j]._stride; } - array_offset_dst += (i / extent) * dest->dim[rank-1]._stride; - void *dst = (void *)((char *) MEMTOK (token) + offset - + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest)); + array_offset_dst += (i / extent) * dest->dim[rank - 1]._stride; + void *dst = (void *) ((char *) MEMTOK (token) + offset + + array_offset_dst * dest->span); void *sr; if (GFC_DESCRIPTOR_RANK (src) != 0) { @@ -1103,8 +1122,7 @@ _gfortran_caf_send (caf_token_t token, size_t offset, stride = src->dim[j]._stride; } array_offset_sr += (i / extent) * src->dim[rank-1]._stride; - sr = (void *)((char *) src->base_addr - + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); + sr = (void *) ((char *) src->base_addr + array_offset_sr * src->span); } else sr = src->base_addr; @@ -2834,6 +2852,108 @@ _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, free (GFC_DESCRIPTOR_DATA (&temp)); } +void +_gfortran_caf_register_accessor (const int hash, accessor_t accessor) +{ + if (accessor_hash_table_state == AHT_UNINITIALIZED) + { + aht_cap = 16; + accessor_hash_table = calloc (aht_cap, sizeof (struct accessor_hash_t)); + accessor_hash_table_state = AHT_OPEN; + } + if (aht_size == aht_cap) + { + aht_cap += 16; + accessor_hash_table = realloc (accessor_hash_table, + aht_cap * sizeof (struct accessor_hash_t)); + } + if (accessor_hash_table_state == AHT_PREPARED) + { + accessor_hash_table_state = AHT_OPEN; + } + accessor_hash_table[aht_size].hash = hash; + accessor_hash_table[aht_size].accessor = accessor; + ++aht_size; +} + +static int +hash_compare (const struct accessor_hash_t *lhs, + const struct accessor_hash_t *rhs) +{ + return lhs->hash < rhs->hash ? -1 : (lhs->hash > rhs->hash ? 1 : 0); +} + +void +_gfortran_caf_register_accessors_finish (void) +{ + if (accessor_hash_table_state == AHT_PREPARED + || accessor_hash_table_state == AHT_UNINITIALIZED) + return; + + qsort (accessor_hash_table, aht_size, sizeof (struct accessor_hash_t), + (int (*) (const void *, const void *)) hash_compare); + accessor_hash_table_state = AHT_PREPARED; +} + +int +_gfortran_caf_get_remote_function_index (const int hash) +{ + if (accessor_hash_table_state != AHT_PREPARED) + { + caf_runtime_error ("the accessor hash table is not prepared."); + } + + struct accessor_hash_t cand; + cand.hash = hash; + struct accessor_hash_t *f + = bsearch (&cand, accessor_hash_table, aht_size, + sizeof (struct accessor_hash_t), + (int (*) (const void *, const void *)) hash_compare); + + int index = f ? f - accessor_hash_table : -1; + return index; +} + +void +_gfortran_caf_get_by_ct ( + caf_token_t token, const gfc_descriptor_t *opt_src_desc, + const size_t *opt_src_charlen, const int image_index __attribute__ ((unused)), + const size_t dst_size __attribute__ ((unused)), void **dst_data, + size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc, + const bool may_realloc_dst, const int getter_index, void *get_data, + const size_t get_data_size __attribute__ ((unused)), int *stat, + caf_team_t *team __attribute__ ((unused)), + int *team_number __attribute__ ((unused))) +{ + caf_single_token_t single_token = TOKEN (token); + void *src_ptr = opt_src_desc ? (void *) opt_src_desc : single_token->memptr; + int free_buffer; + void *dst_ptr = opt_dst_desc ? (void *)opt_dst_desc : dst_data; + void *old_dst_data_ptr = NULL; + + if (stat) + *stat = 0; + + if (opt_dst_desc && !may_realloc_dst) + { + old_dst_data_ptr = opt_dst_desc->base_addr; + opt_dst_desc->base_addr = NULL; + } + + accessor_hash_table[getter_index].accessor (dst_ptr, &free_buffer, src_ptr, + get_data, opt_src_charlen, + opt_dst_charlen); + if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst + && opt_dst_desc->base_addr != old_dst_data_ptr) + { + size_t dsize = opt_dst_desc->span; + for (int i = 0; i < GFC_DESCRIPTOR_RANK (opt_dst_desc); ++i) + dsize *= GFC_DESCRIPTOR_EXTENT (opt_dst_desc, i); + memcpy (old_dst_data_ptr, opt_dst_desc->base_addr, dsize); + free (opt_dst_desc->base_addr); + opt_dst_desc->base_addr = old_dst_data_ptr; + } +} void _gfortran_caf_atomic_define (caf_token_t token, size_t offset,