Refactor to use send_to_remote instead of the slow send_by_ref.
gcc/fortran/ChangeLog:
PR fortran/107635
* coarray.cc (move_coarray_ref): Move the coarray reference out
of the given one. Especially when there is a regular array ref.
(fixup_comp_refs): Move components refs to a derived type where
the codim has been removed, aka a new type.
(split_expr_at_caf_ref): Correctly split the reference chain.
(remove_caf_ref): Simplify.
(create_get_callback): Fix some deficiencies.
(create_allocated_callback): Adapt to new signature of split.
(create_send_callback): New function.
(rewrite_caf_send): Rewrite a call to caf_send to
caf_send_to_remote.
(coindexed_code_callback): Treat caf_send and caf_sendget
correctly.
* gfortran.h (enum gfc_isym_id): Add SENDGET-isym.
* gfortran.texi: Add documentation for send_to_remote.
* resolve.cc (gfc_resolve_code): No longer generate send_by_ref
when allocatable coarray (component) is on the lhs.
* trans-decl.cc (gfc_build_builtin_function_decls): Add
caf_send_to_remote decl.
* trans-intrinsic.cc (conv_caf_func_index): Ensure the static
variables created are not in a block-scope.
(conv_caf_send_to_remote): Translate caf_send_to_remote calls.
(conv_caf_send): Renamed to conv_caf_sendget.
(conv_caf_sendget): Renamed from conv_caf_send.
(gfc_conv_intrinsic_subroutine): Branch correctly for
conv_caf_send and sendget.
* trans.h: Correct decl.
libgfortran/ChangeLog:
* caf/libcaf.h: Add/Correct prototypes for caf_get_from_remote,
caf_send_to_remote.
* caf/single.c (struct accessor_hash_t): Rename accessor_t to
getter_t.
(_gfortran_caf_register_accessor): Use new name of getter_t.
(_gfortran_caf_send_to_remote): New function for sending data to
coarray on a remote image.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/send_char_array_1.f90: Extend test to
catch more cases.
* gfortran.dg/coarray_42.f90: Invert tests use, because no
longer a send is needed when local memory in a coarray is
allocated.
base->attr.pointer = 0; // Ensure, that it is no pointer.
}
+static void
+move_coarray_ref (gfc_ref **from, gfc_expr *expr)
+{
+ int i;
+ gfc_ref *to = expr->ref;
+ for (; to && to->next; to = to->next)
+ ;
+
+ if (!to)
+ {
+ expr->ref = gfc_get_ref ();
+ to = expr->ref;
+ to->type = REF_ARRAY;
+ }
+ gcc_assert (to->type == REF_ARRAY);
+ to->u.ar.as = gfc_copy_array_spec ((*from)->u.ar.as);
+ to->u.ar.codimen = (*from)->u.ar.codimen;
+ to->u.ar.dimen = (*from)->u.ar.dimen;
+ to->u.ar.type = AR_FULL;
+ to->u.ar.stat = (*from)->u.ar.stat;
+ (*from)->u.ar.stat = nullptr;
+ to->u.ar.team = (*from)->u.ar.team;
+ (*from)->u.ar.team = nullptr;
+ for (i = 0; i < to->u.ar.dimen; ++i)
+ {
+ to->u.ar.start[i] = nullptr;
+ to->u.ar.end[i] = nullptr;
+ to->u.ar.stride[i] = nullptr;
+ }
+ for (i = (*from)->u.ar.dimen; i < (*from)->u.ar.dimen + (*from)->u.ar.codimen;
+ ++i)
+ {
+ to->u.ar.dimen_type[i] = (*from)->u.ar.dimen_type[i];
+ to->u.ar.start[i] = (*from)->u.ar.start[i];
+ (*from)->u.ar.start[i] = nullptr;
+ to->u.ar.end[i] = (*from)->u.ar.end[i];
+ (*from)->u.ar.end[i] = nullptr;
+ to->u.ar.stride[i] = (*from)->u.ar.stride[i];
+ (*from)->u.ar.stride[i] = nullptr;
+ }
+ (*from)->u.ar.codimen = 0;
+ if ((*from)->u.ar.dimen == 0)
+ {
+ gfc_ref *nref = (*from)->next;
+ (*from)->next = nullptr;
+ gfc_free_ref_list (*from);
+ *from = nref;
+ }
+}
+
+static void
+fixup_comp_refs (gfc_expr *expr)
+{
+ gfc_symbol *type = expr->symtree->n.sym->ts.type == BT_DERIVED
+ ? expr->symtree->n.sym->ts.u.derived
+ : (expr->symtree->n.sym->ts.type == BT_CLASS
+ ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived
+ : nullptr);
+ if (!type)
+ return;
+ gfc_ref **pref = &(expr->ref);
+ for (gfc_ref *ref = expr->ref; ref && type;)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ gfc_find_component (type, ref->u.c.component->name, false, true,
+ pref);
+ if (!*pref)
+ {
+ /* This happens when there were errors previously. Just don't
+ crash. */
+ ref = nullptr;
+ break;
+ }
+ (*pref)->next = ref->next;
+ ref->next = NULL;
+ gfc_free_ref_list (ref);
+ ref = (*pref)->next;
+ type = (*pref)->u.c.component->ts.type == BT_DERIVED
+ ? (*pref)->u.c.component->ts.u.derived
+ : ((*pref)->u.c.component->ts.type == BT_CLASS
+ ? CLASS_DATA ((*pref)->u.c.component)->ts.u.derived
+ : nullptr);
+ pref = &(*pref)->next;
+ break;
+ case REF_ARRAY:
+ pref = &ref->next;
+ ref = ref->next;
+ break;
+ default:
+ gcc_unreachable ();
+ break;
+ }
+ }
+}
+
static void
split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
- gfc_expr **post_caf_ref_expr)
+ gfc_expr **post_caf_ref_expr, bool for_send)
{
gfc_ref *caf_ref = NULL;
gfc_symtree *st;
gfc_symbol *base;
+ gfc_typespec *caf_ts;
bool created;
gcc_assert (expr->expr_type == EXPR_VARIABLE);
+ caf_ts = &expr->symtree->n.sym->ts;
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)
+ if (caf_ref->type == REF_ARRAY && caf_ref->u.ar.codimen != 0)
break;
+ if (caf_ref->type == REF_COMPONENT)
+ caf_ts = &caf_ref->u.c.component->ts;
caf_ref = caf_ref->next;
}
}
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;
+ st->n.sym->ts = *caf_ts;
*post_caf_ref_expr = gfc_get_variable_expr (st);
(*post_caf_ref_expr)->where = expr->where;
if (!caf_ref)
{
- (*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref);
+ (*post_caf_ref_expr)->ref = gfc_get_ref ();
+ *(*post_caf_ref_expr)->ref = *expr->ref;
+ expr->ref = nullptr;
+ move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
+ fixup_comp_refs (expr);
+
if (expr->symtree->n.sym->attr.dimension)
{
base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
}
else
{
- (*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next);
- if (caf_ref->u.c.component->attr.dimension)
+ (*post_caf_ref_expr)->ref = gfc_get_ref ();
+ *(*post_caf_ref_expr)->ref = *caf_ref;
+ caf_ref->next = nullptr;
+ move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
+ fixup_comp_refs (expr);
+
+ if (caf_ref && caf_ref->u.ar.dimen)
{
- base->as = gfc_copy_array_spec (caf_ref->u.c.component->as);
+ base->as = gfc_copy_array_spec (caf_ref->u.ar.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->attr.allocatable = caf_ref->u.ar.as->type != AS_EXPLICIT;
}
- base->ts = caf_ref->u.c.component->ts;
+ base->ts = *caf_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.u.cl = *(caf_ts->u.cl);
base->ts.deferred = 1;
base->ts.u.cl->length = nullptr;
}
-
- if (base->ts.type == BT_DERIVED)
+ else 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);
+ if (for_send)
+ gfc_expression_rank (expr);
+ else
+ expr->rank = (*post_caf_ref_expr)->rank;
}
static void add_caf_get_from_remote (gfc_expr *e);
static void
remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false)
{
- gfc_ref *ref = expr->ref, **pref = &expr->ref;
+ gfc_ref *ref = expr->ref;
while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
{
ref = ref->next;
- pref = &ref->next;
}
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
ref->next = NULL;
gfc_free_ref_list (ref);
ref = expr->ref;
- pref = &expr->ref;
}
}
}
- if (ref && ref->type == REF_COMPONENT)
- {
- gfc_find_component (expr->symtree->n.sym->ts.u.derived,
- ref->u.c.component->name, false, true, pref);
- if (*pref && *pref != ref)
- {
- (*pref)->next = ref->next;
- ref->next = NULL;
- gfc_free_ref_list (ref);
- }
- }
+ fixup_comp_refs (expr);
}
static gfc_expr *
mname = expr->symtree->n.sym->module;
else
mname = "main";
- name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++caf_sym_cnt);
+ name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
gfc_get_symbol (name, ns, &extproc);
extproc->declared_at = expr->where;
gfc_set_sym_referenced (extproc);
gfc_commit_symbol (proc);
free (name);
- split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr);
+ split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, false);
if (ns->proc_name->attr.flavor == FL_MODULE)
proc->module = ns->proc_name->name;
{
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;
+ buffer->ts.u.cl->length = gfc_copy_expr (expr->ts.u.cl->length);
}
gfc_commit_symbol (buffer);
remove_caf_ref (post_caf_ref_expr);
get_data->ts.u.derived
= create_caf_add_data_parameter_type (code->expr2, ns, get_data);
- if (code->expr2->rank == 0)
+ if (code->expr2->rank == 0 && code->expr2->ts.type != BT_CHARACTER)
code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
gfc_current_locus, 1, code->expr2);
free (name);
split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns,
- &post_caf_ref_expr);
+ &post_caf_ref_expr, true);
if (ns->proc_name->attr.flavor == FL_MODULE)
proc->module = ns->proc_name->name;
"caf_is_present_on_remote", (*e)->where, 3, *e,
present_hash_expr, present_fn_expr);
gfc_add_caf_accessor (present_hash_expr, present_fn_expr);
- wrapper->ts = (*e)->ts;
*e = wrapper;
}
+static gfc_expr *
+create_send_callback (gfc_expr *expr, gfc_expr *rhs)
+{
+ gfc_namespace *ns;
+ gfc_symbol *extproc, *proc, *buffer, *base, *send_data, *caller_image;
+ char tname[GFC_MAX_SYMBOL_LEN + 1];
+ char *name;
+ const char *mname;
+ gfc_expr *cb, *post_caf_ref_expr;
+ gfc_code *code;
+ gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
+ caf_accessor_prepend = nullptr;
+
+ /* 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_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
+ gfc_get_symbol (name, ns, &extproc);
+ extproc->declared_at = expr->where;
+ 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;
+ proc->declared_at = expr->where;
+ gfc_commit_symbol (proc);
+ free (name);
+
+ split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, true);
+
+ 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, skind, sintent) \
+ gfc_get_symbol (name, sub_ns, &nsym); \
+ nsym->ts.type = stype; \
+ nsym->ts.kind = skind; \
+ nsym->attr.flavor = FL_PARAMETER; \
+ nsym->attr.dummy = 1; \
+ nsym->attr.intent = sintent; \
+ nsym->declared_at = expr->where; \
+ gfc_set_sym_referenced (nsym); \
+ *argptr = gfc_get_formal_arglist (); \
+ (*argptr)->sym = nsym; \
+ argptr = &(*argptr)->next
+
+ name = xasprintf ("add_send_data_%s_%s_%d", mname, tname, caf_sym_cnt);
+ ADD_ARG (name, send_data, BT_DERIVED, 0, INTENT_IN);
+ gfc_commit_symbol (send_data);
+ free (name);
+
+ ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
+ INTENT_IN);
+ gfc_commit_symbol (caller_image);
+
+ // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
+ base = post_caf_ref_expr->symtree->n.sym;
+ base->attr.intent = INTENT_INOUT;
+ 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 ("buffer", buffer, rhs->ts.type, rhs->ts.kind, INTENT_IN);
+ buffer->ts = rhs->ts;
+ if (rhs->rank)
+ {
+ buffer->as = gfc_get_array_spec ();
+ buffer->as->rank = rhs->rank;
+ buffer->as->type = AS_DEFERRED;
+ buffer->attr.allocatable = 1;
+ buffer->attr.dimension = 1;
+ }
+ if (buffer->ts.type == BT_CHARACTER)
+ {
+ buffer->ts.u.cl = gfc_get_charlen ();
+ *buffer->ts.u.cl = *rhs->ts.u.cl;
+ buffer->ts.deferred = 1;
+ buffer->ts.u.cl->length = gfc_copy_expr (rhs->ts.u.cl->length);
+ }
+ gfc_commit_symbol (buffer);
+#undef ADD_ARG
+
+ /* Set up code. */
+ /* Code: base = buffer; */
+ code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
+ code->loc = expr->where;
+ code->expr1 = post_caf_ref_expr;
+ if (code->expr1->ts.type == BT_CHARACTER
+ && code->expr1->ts.kind != buffer->ts.kind)
+ {
+ bool converted;
+ code->expr2 = gfc_lval_expr_from_sym (buffer);
+ converted = gfc_convert_chartype (code->expr2, &code->expr1->ts);
+ gcc_assert (converted);
+ }
+ else if (code->expr1->ts.type != buffer->ts.type)
+ {
+ bool converted;
+ code->expr2 = gfc_lval_expr_from_sym (buffer);
+ converted = gfc_convert_type_warn (code->expr2, &code->expr1->ts, 0, 0,
+ buffer->attr.dimension);
+ gcc_assert (converted);
+ }
+ else
+ code->expr2 = gfc_lval_expr_from_sym (buffer);
+ remove_caf_ref (post_caf_ref_expr);
+ send_data->ts.u.derived
+ = create_caf_add_data_parameter_type (code->expr1, ns, send_data);
+
+ cb = gfc_lval_expr_from_sym (extproc);
+ cb->ts.interface = extproc;
+
+ if (caf_accessor_prepend)
+ {
+ gfc_code *c = caf_accessor_prepend;
+ /* Find last in chain. */
+ for (; c->next; c = c->next)
+ ;
+ c->next = sub_ns->code;
+ sub_ns->code = caf_accessor_prepend;
+ }
+ caf_accessor_prepend = backup_caf_accessor_prepend;
+ return cb;
+}
+
+static void
+rewrite_caf_send (gfc_code *c)
+{
+ gfc_expr *send_to_remote_expr, *send_to_remote_hash_expr, *lhs, *rhs;
+ gfc_actual_arglist *arg = c->ext.actual;
+
+ lhs = arg->expr;
+ arg = arg->next;
+ rhs = arg->expr;
+ /* Detect an already rewritten caf_send. */
+ if (arg->next && arg->next->expr->expr_type == EXPR_CONSTANT
+ && arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE)
+ return;
+
+ if (gfc_is_coindexed (rhs))
+ {
+ c->resolved_isym->id = GFC_ISYM_CAF_SENDGET;
+ return;
+ }
+
+ send_to_remote_expr = create_send_callback (lhs, rhs);
+ send_to_remote_hash_expr = gfc_get_expr ();
+ send_to_remote_hash_expr->expr_type = EXPR_CONSTANT;
+ send_to_remote_hash_expr->ts.type = BT_INTEGER;
+ send_to_remote_hash_expr->ts.kind = gfc_default_integer_kind;
+ send_to_remote_hash_expr->where = lhs->where;
+ mpz_init_set_ui (send_to_remote_hash_expr->value.integer,
+ gfc_hash_value (send_to_remote_expr->symtree->n.sym));
+ arg->next = gfc_get_actual_arglist ();
+ arg = arg->next;
+ arg->expr = send_to_remote_hash_expr;
+ arg->next = gfc_get_actual_arglist ();
+ arg = arg->next;
+ arg->expr = send_to_remote_expr;
+ gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr);
+}
+
static int
coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
void *data ATTRIBUTE_UNUSED)
*walk_subtrees = 0;
break;
case EXEC_CALL:
- *walk_subtrees
- = !((*c)->resolved_isym
- && ((*c)->resolved_isym->id == GFC_ISYM_CAF_SEND
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_ADD
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_AND
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_CAS
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_DEF
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_ADD
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_AND
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_OR
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_XOR
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_OR
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_REF
- || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_XOR));
+ *walk_subtrees = 1;
+ if ((*c)->resolved_isym)
+ switch ((*c)->resolved_isym->id)
+ {
+ case GFC_ISYM_CAF_SEND:
+ rewrite_caf_send (*c);
+ *walk_subtrees = 0;
+ break;
+ case GFC_ISYM_CAF_SENDGET:
+ // rewrite_caf_sendget (*c);
+ *walk_subtrees = 0;
+ break;
+ case GFC_ISYM_ATOMIC_ADD:
+ case GFC_ISYM_ATOMIC_AND:
+ case GFC_ISYM_ATOMIC_CAS:
+ case GFC_ISYM_ATOMIC_DEF:
+ case GFC_ISYM_ATOMIC_FETCH_ADD:
+ case GFC_ISYM_ATOMIC_FETCH_AND:
+ case GFC_ISYM_ATOMIC_FETCH_OR:
+ case GFC_ISYM_ATOMIC_FETCH_XOR:
+ case GFC_ISYM_ATOMIC_OR:
+ case GFC_ISYM_ATOMIC_REF:
+ case GFC_ISYM_ATOMIC_XOR:
+ *walk_subtrees = 0;
+ break;
+ default:
+ break;
+ }
break;
default:
*walk_subtrees = 1;
GFC_ISYM_CAF_GET,
GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
GFC_ISYM_CAF_SEND,
+ GFC_ISYM_CAF_SENDGET,
GFC_ISYM_CEILING,
GFC_ISYM_CHAR,
GFC_ISYM_CHDIR,
* _gfortran_caf_get_by_ref:: Getting data from a remote image using enhanced references
* _gfortran_caf_get_from_remote:: Getting data from a remote image using a remote side accessor
* _gfortran_caf_is_present_on_remote:: Check that a coarray or a part of it is allocated on the remote image
+* _gfortran_caf_send_to_remote:: Send data to a remote image using a remote side accessor to store it
* _gfortran_caf_sendget_by_ref:: Sending data between remote images using enhanced references
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
@end table
+@node _gfortran_caf_send_to_remote
+@subsection @code{_gfortran_caf_send_to_remote} --- Send data to a remote image using a remote side accessor to store it
+@cindex Coarray, _gfortran_caf_send_to_remote
+
+@table @asis
+@item @emph{Description}:
+Called to send a scalar, an array section or a whole array to a remote image
+identified by the @var{image_index}. The call modifies the memory of the remote
+image.
+
+@item @emph{Syntax}:
+@code{void _gfortran_caf_send_to_remote (caf_token_t token,
+gfc_descriptor_t *opt_dst_desc, const size_t *opt_dst_charlen,
+const int image_index, const size_t src_size, const void *src_data,
+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, 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_dst_desc} @tab intent(inout) 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
+or is an array without a descriptor.
+@item @var{opt_dst_charlen} @tab intent(in) When the object to send 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{src_size} @tab intent(in) The size of data expected to be transferred
+to 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 given
+in @code{opt_src_charlen} (also for string arrays).
+@item @var{src_data} @tab intent(in) A pointer the data to be send to the remote
+image. When a descriptor is provided in @code{opt_src_desc} then this parameter
+can be ignored by the library implementing the coarray functionality.
+@item @var{opt_src_charlen} @tab intent(in) When a char array is send, this
+parameter is set to its length.
+@item @var{opt_src_desc} @tab intent(in) When a descriptor array is send, then
+this parameter gives the handle.
+@item @var{setter_index} @tab intent(in) The index of the accessor to execute
+as returned by @code{_gfortran_caf_get_remote_function_index ()}.
+@item @var{add_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{add_data} may be changed by the
+accessor, but these changes are lost to the calling Fortran program.
+@item @var{add_data_size} @tab intent(in) The size of the @var{add_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 send the data to and the memory to read for 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
break;
if (flag_coarray == GFC_FCOARRAY_LIB
- && (gfc_is_coindexed (code->expr1)
- || caf_possible_reallocate (code->expr1)))
+ && gfc_is_coindexed (code->expr1))
{
/* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
coindexed variable. */
tree gfor_fndecl_caf_register_accessors_finish;
tree gfor_fndecl_caf_get_remote_function_index;
tree gfor_fndecl_caf_get_from_remote;
+tree gfor_fndecl_caf_send_to_remote;
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
boolean_type_node, integer_type_node, pvoid_type_node, size_type_node,
pint_type, pvoid_type_node, pint_type);
+ gfor_fndecl_caf_send_to_remote
+ = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("caf_send_to_remote")),
+ ". r r r r r r r r r w r w r r ", void_type_node, 14, pvoid_type_node,
+ pvoid_type_node, psize_type, integer_type_node, size_type_node,
+ ppvoid_type_node, psize_type, pvoid_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,
3, pint_type, pchar_type_node, size_type_node);
tree func_index_tree;
stmtblock_t blk;
+ /* Need to get namespace where static variables are possible. */
+ while (ns && ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
+ ns = ns->parent;
+ gcc_assert (ns);
+
name = xasprintf (pat, caf_call_cnt);
gcc_assert (!gfc_get_sym_tree (name, ns, &index_st, false));
free (name);
add_data_tree, add_data_size));
}
+static tree
+conv_caf_send_to_remote (gfc_code *code)
+{
+ gfc_expr *lhs_expr, *rhs_expr, *lhs_hash, *receiver_fn_expr, *tmp_stat,
+ *tmp_team;
+ gfc_symbol *add_data_sym;
+ gfc_se lhs_se, rhs_se;
+ stmtblock_t block;
+ gfc_namespace *ns;
+ tree caf_decl, token, rhs_size, image_index, tmp, rhs_data;
+ tree lhs_stat, lhs_team, opt_lhs_charlen, opt_rhs_charlen;
+ tree opt_lhs_desc = NULL_TREE, opt_rhs_desc = NULL_TREE;
+ tree receiver_fn_index_tree, add_data_tree, add_data_size;
+
+ gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
+ gcc_assert (code->resolved_isym->id == GFC_ISYM_CAF_SEND);
+
+ lhs_expr = code->ext.actual->expr;
+ rhs_expr = code->ext.actual->next->expr;
+ lhs_hash = code->ext.actual->next->next->expr;
+ receiver_fn_expr = code->ext.actual->next->next->next->expr;
+ add_data_sym = receiver_fn_expr->symtree->n.sym->formal->sym;
+
+ ns = lhs_expr->expr_type == EXPR_VARIABLE
+ && !lhs_expr->symtree->n.sym->attr.associate_var
+ ? lhs_expr->symtree->n.sym->ns
+ : gfc_current_ns;
+
+ gfc_init_block (&block);
+
+ lhs_stat = null_pointer_node;
+ lhs_team = null_pointer_node;
+
+ /* LHS. */
+ gfc_init_se (&lhs_se, NULL);
+ caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
+ if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+ caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
+ if (lhs_expr->rank == 0)
+ {
+ if (lhs_expr->ts.type == BT_CHARACTER)
+ {
+ gfc_conv_string_length (lhs_expr->ts.u.cl, lhs_expr, &block);
+ lhs_se.string_length = lhs_expr->ts.u.cl->backend_decl;
+ opt_lhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
+ }
+ else
+ opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
+ opt_lhs_desc = null_pointer_node;
+ }
+ else
+ {
+ gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
+ gfc_add_block_to_block (&block, &lhs_se.pre);
+ opt_lhs_desc = lhs_se.expr;
+ if (lhs_expr->ts.type == BT_CHARACTER)
+ opt_lhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, lhs_se.string_length));
+ else
+ opt_lhs_charlen = build_zero_cst (build_pointer_type (size_type_node));
+ if (!TYPE_LANG_SPECIFIC (TREE_TYPE (caf_decl))->rank
+ || GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)))
+ opt_lhs_desc = null_pointer_node;
+ else
+ opt_lhs_desc
+ = gfc_build_addr_expr (NULL_TREE,
+ gfc_trans_force_lval (&block, opt_lhs_desc));
+ }
+
+ /* Obtain token, offset and image index for the LHS. */
+ image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
+ gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL, lhs_expr);
+
+ /* RHS. */
+ gfc_init_se (&rhs_se, NULL);
+ if (rhs_expr->rank == 0)
+ {
+ gfc_conv_expr (&rhs_se, rhs_expr);
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+ opt_rhs_desc = null_pointer_node;
+ if (rhs_expr->ts.type == BT_CHARACTER)
+ {
+ rhs_data
+ = rhs_expr->expr_type == EXPR_CONSTANT
+ ? gfc_build_addr_expr (NULL_TREE,
+ gfc_trans_force_lval (&block,
+ rhs_se.expr))
+ : rhs_se.expr;
+ opt_rhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
+ rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
+ }
+ else
+ {
+ rhs_data
+ = gfc_build_addr_expr (NULL_TREE,
+ gfc_trans_force_lval (&block, rhs_se.expr));
+ opt_rhs_charlen
+ = build_zero_cst (build_pointer_type (size_type_node));
+ rhs_size = rhs_se.expr->typed.type->type_common.size_unit;
+ }
+ }
+ else
+ {
+ rhs_se.force_tmp = rhs_expr->shape == NULL
+ || !gfc_is_simply_contiguous (rhs_expr, false, false);
+ gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+ opt_rhs_desc = rhs_se.expr;
+ if (rhs_expr->ts.type == BT_CHARACTER)
+ {
+ opt_rhs_charlen = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, rhs_se.string_length));
+ rhs_size = build_int_cstu (size_type_node, rhs_expr->ts.kind);
+ }
+ else
+ {
+ opt_rhs_charlen
+ = build_zero_cst (build_pointer_type (size_type_node));
+ rhs_size = fold_build2 (
+ MULT_EXPR, size_type_node,
+ fold_convert (size_type_node,
+ rhs_expr->shape
+ ? conv_shape_to_cst (rhs_expr)
+ : gfc_conv_descriptor_size (rhs_se.expr,
+ rhs_expr->rank)),
+ fold_convert (size_type_node,
+ gfc_conv_descriptor_span_get (rhs_se.expr)));
+ }
+
+ rhs_data = gfc_build_addr_expr (
+ NULL_TREE, gfc_trans_force_lval (&block, gfc_conv_descriptor_data_get (
+ opt_rhs_desc)));
+ opt_rhs_desc = gfc_build_addr_expr (NULL_TREE, opt_rhs_desc);
+ }
+ gfc_add_block_to_block (&block, &rhs_se.pre);
+
+ tmp_stat = gfc_find_stat_co (lhs_expr);
+
+ if (tmp_stat)
+ {
+ gfc_se stat_se;
+ gfc_init_se (&stat_se, NULL);
+ gfc_conv_expr_reference (&stat_se, tmp_stat);
+ lhs_stat = stat_se.expr;
+ gfc_add_block_to_block (&block, &stat_se.pre);
+ gfc_add_block_to_block (&block, &stat_se.post);
+ }
+
+ tmp_team = gfc_find_team_co (lhs_expr);
+
+ if (tmp_team)
+ {
+ gfc_se team_se;
+ gfc_init_se (&team_se, NULL);
+ gfc_conv_expr_reference (&team_se, tmp_team);
+ lhs_team = team_se.expr;
+ gfc_add_block_to_block (&block, &team_se.pre);
+ gfc_add_block_to_block (&block, &team_se.post);
+ }
+
+ receiver_fn_index_tree
+ = conv_caf_func_index (&block, ns, "__caf_send_to_remote_fn_index_%d",
+ lhs_hash);
+ add_data_tree
+ = conv_caf_add_call_data (&block, ns, "__caf_send_to_remote_add_data_%d",
+ add_data_sym, &add_data_size);
+ ++caf_call_cnt;
+
+ tmp
+ = build_call_expr_loc (input_location, gfor_fndecl_caf_send_to_remote, 14,
+ token, opt_lhs_desc, opt_lhs_charlen, image_index,
+ rhs_size, rhs_data, opt_rhs_charlen, opt_rhs_desc,
+ receiver_fn_index_tree, add_data_tree, add_data_size,
+ lhs_stat, lhs_team, null_pointer_node);
+
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &lhs_se.post);
+ gfc_add_block_to_block (&block, &rhs_se.post);
+
+ /* 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 (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
+
static bool
has_ref_after_cafref (gfc_expr *expr)
{
return false;
}
-/* Send data to a remote coarray. */
+/* Send-get data to a remote coarray. */
static tree
-conv_caf_send (gfc_code *code) {
+conv_caf_sendget (gfc_code *code)
+{
gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
gfc_se lhs_se, rhs_se;
stmtblock_t block;
return gfc_finish_block (&block);
}
-
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
break;
case GFC_ISYM_CAF_SEND:
- res = conv_caf_send (code);
+ res = conv_caf_send_to_remote (code);
+ break;
+
+ case GFC_ISYM_CAF_SENDGET:
+ res = conv_caf_sendget (code);
break;
case GFC_ISYM_CO_BROADCAST:
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_from_remote;
+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_from_remote;
+extern GTY(()) tree gfor_fndecl_caf_send_to_remote;
extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_memory;
co_str_k1_arr(:)[this_image()] = str_k1_arr
if (any(co_str_k1_arr /= ['abc ', 'EFG ', 'klm ', 'NOP '])) STOP 5
-
- co_str_k4_arr(:)[this_image()] = [4_'abc', 4_'EFG', 4_'klm', 4_'NOP']! str_k4_arr
- if (any(co_str_k4_arr /= [4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 6
+ co_str_k4_arr(:)[this_image()] = str_k4_arr
+ if (any(co_str_k4_arr /= [4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 6
+
co_str_k4_arr(:)[this_image()] = str_k1_arr
if (any(co_str_k4_arr /= [ 4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 7
co_str_k1_arr(:)[this_image()] = str_k4_arr
if (any(co_str_k1_arr /= ['abc ', 'EFG ', 'klm ', 'NOP '])) STOP 8
+ co_str_k1_arr(:)[this_image()] = ['abc', 'EFG', 'klm', 'NOP']
+ if (any(co_str_k1_arr /= ['abc ', 'EFG ', 'klm ', 'NOP '])) STOP 9
+
+ co_str_k4_arr(:)[this_image()] = [4_'abc', 4_'EFG', 4_'klm', 4_'NOP']
+ if (any(co_str_k4_arr /= [4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 10
+
end program send_convert_char_array
-! vim:ts=2:sts=2:sw=2:
allocate(D[2,2,*])
allocate(D%endsi(2), source = 0)
- ! Lhs may be reallocate, so caf_send_by_ref needs to be used.
+ ! Lhs may be reallocate. Due to new communication pattern no send.
D%endsi = D%n
if (any(D%endsi /= [ 64, 64])) error stop
deallocate(D)
end program
-! { dg-final { scan-tree-dump-times "caf_send_by_ref" 1 "original" } }
+! { dg-final { scan-tree-dump-not "caf_send" "original" } }
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);
+ const bool may_realloc_dst, const int accessor_index, void *add_data,
+ const size_t add_data_size, int *stat, caf_team_t *team, int *team_number);
int32_t _gfortran_caf_is_present_on_remote (caf_token_t token, int, int,
void *add_data,
const size_t add_data_size);
+void _gfortran_caf_send_to_remote (
+ caf_token_t token, gfc_descriptor_t *opt_dst_desc,
+ const size_t *opt_dst_charlen, const int image_index, const size_t src_size,
+ const void *src_data, const size_t *opt_src_charlen,
+ const gfc_descriptor_t *opt_src_desc, const int accessor_index,
+ void *add_data, const size_t add_data_size, 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 *,
/* Global variables. */
caf_static_t *caf_static_list = NULL;
-typedef void (*accessor_t) (void *, const int *, void **, int32_t *, void *,
- caf_token_t, const size_t, size_t *,
- const size_t *);
+typedef void (*getter_t) (void *, const int *, void **, int32_t *, void *,
+ caf_token_t, const size_t, size_t *, const size_t *);
typedef void (*is_present_t) (void *, const int *, int32_t *, void *,
caf_single_token_t, const size_t);
+typedef void (*receiver_t) (void *, const int *, void *, const void *,
+ caf_token_t, const size_t, const size_t *,
+ const size_t *);
struct accessor_hash_t
{
int hash;
int pad;
union
{
- accessor_t accessor;
+ getter_t getter;
is_present_t is_present;
+ receiver_t receiver;
} u;
};
}
void
-_gfortran_caf_register_accessor (const int hash, accessor_t accessor)
+_gfortran_caf_register_accessor (const int hash, getter_t accessor)
{
if (accessor_hash_table_state == AHT_UNINITIALIZED)
{
accessor_hash_table_state = AHT_OPEN;
}
accessor_hash_table[aht_size].hash = hash;
- accessor_hash_table[aht_size].u.accessor = accessor;
+ accessor_hash_table[aht_size].u.getter = accessor;
++aht_size;
}
const size_t *opt_src_charlen, const int image_index,
const size_t dst_size __attribute__ ((unused)), void **dst_data,
size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc,
- const bool may_realloc_dst, const int getter_index, void *get_data,
- const size_t get_data_size __attribute__ ((unused)), int *stat,
+ 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)))
{
void *dst_ptr = opt_dst_desc ? (void *)opt_dst_desc : dst_data;
void *old_dst_data_ptr = NULL;
struct caf_single_token cb_token;
- cb_token.memptr = get_data;
+ cb_token.memptr = add_data;
cb_token.desc = NULL;
cb_token.owning_memory = false;
opt_dst_desc->base_addr = NULL;
}
- accessor_hash_table[getter_index].u.accessor (get_data, &image_index, dst_ptr,
- &free_buffer, src_ptr,
- &cb_token, 0, opt_dst_charlen,
- opt_src_charlen);
+ accessor_hash_table[getter_index].u.getter (add_data, &image_index, dst_ptr,
+ &free_buffer, src_ptr, &cb_token,
+ 0, opt_dst_charlen,
+ opt_src_charlen);
if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst
&& opt_dst_desc->base_addr != old_dst_data_ptr)
{
return result;
}
+void
+_gfortran_caf_send_to_remote (
+ caf_token_t token, gfc_descriptor_t *opt_dst_desc,
+ const size_t *opt_dst_charlen, const int image_index,
+ const size_t src_size __attribute__ ((unused)), const void *src_data,
+ const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc,
+ const int accessor_index, void *add_data,
+ const size_t add_data_size __attribute__ ((unused)), int *stat,
+ caf_team_t *team __attribute__ ((unused)),
+ int *team_number __attribute__ ((unused)))
+{
+ caf_single_token_t single_token = TOKEN (token);
+ void *dst_ptr = opt_dst_desc ? (void *) opt_dst_desc : single_token->memptr;
+ const void *src_ptr = opt_src_desc ? (void *) opt_src_desc : src_data;
+ struct caf_single_token cb_token;
+ cb_token.memptr = add_data;
+ cb_token.desc = NULL;
+ cb_token.owning_memory = false;
+
+ if (stat)
+ *stat = 0;
+
+ accessor_hash_table[accessor_index].u.receiver (add_data, &image_index,
+ dst_ptr, src_ptr, &cb_token,
+ 0, opt_dst_charlen,
+ opt_src_charlen);
+}
+
void
_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
int image_index __attribute__ ((unused)),
projects / thirdparty / gcc.git / commitdiff
