procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Add send_to_remote [PR107635]

Browse source 
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.
This commit is contained in:
Andre Vehreschild 2025-01-29 12:42:18 +01:00
parent 1584725264
commit 69eb02682b
11 changed files with 706 additions and 83 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

402
gcc/fortran/coarray.cc
View file

@ -242,25 +242,125 @@ convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
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;
}
}
@ -271,7 +371,7 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
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;
@ -279,7 +379,12 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
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);
@ -292,34 +397,39 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
}
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);
@ -647,18 +757,16 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns,
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
@ -675,21 +783,10 @@ remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false)
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 *
@ -719,7 +816,7 @@ create_get_callback (gfc_expr *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);
@ -744,7 +841,7 @@ create_get_callback (gfc_expr *expr)
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;
@ -809,8 +906,7 @@ create_get_callback (gfc_expr *expr)
{
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);
@ -857,7 +953,7 @@ create_get_callback (gfc_expr *expr)
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);
@ -994,7 +1090,7 @@ create_allocated_callback (gfc_expr *expr)
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;
@ -1086,10 +1182,198 @@ rewrite_caf_allocated (gfc_expr **e)
"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)
@ -1158,20 +1442,34 @@ coindexed_code_callback (gfc_code **c, int *walk_subtrees,
*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;

1
gcc/fortran/gfortran.h
View file

@ -458,6 +458,7 @@ enum gfc_isym_id
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,

69
gcc/fortran/gfortran.texi
View file

@ -4213,6 +4213,7 @@ future implementation of teams. It is about to change without further notice.
* _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
@ -5084,6 +5085,74 @@ structure.
@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

3
gcc/fortran/resolve.cc
View file

@ -13353,8 +13353,7 @@ start:
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. */

10
gcc/fortran/trans-decl.cc
View file

@ -148,6 +148,7 @@ 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_from_remote;
tree gfor_fndecl_caf_send_to_remote;
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
@ -4134,6 +4135,15 @@ gfc_build_builtin_function_decls (void)
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);

209
gcc/fortran/trans-intrinsic.cc
View file

@ -1681,6 +1681,11 @@ conv_caf_func_index (stmtblock_t *block, gfc_namespace *ns, const char *pat,
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);
@ -2006,6 +2011,198 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
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)
{
@ -2015,10 +2212,11 @@ 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;
@ -2461,7 +2659,6 @@ conv_caf_send (gfc_code *code) {
return gfc_finish_block (&block);
}
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
{
@ -13843,7 +14040,11 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
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:

9
gcc/fortran/trans.h
View file

@ -892,10 +892,11 @@ 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_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;

13
gcc/testsuite/gfortran.dg/coarray/send_char_array_1.f90
View file

@ -39,16 +39,21 @@ program send_convert_char_array
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:

4
gcc/testsuite/gfortran.dg/coarray_42.f90
View file

@ -11,11 +11,11 @@ program Jac
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" } }

12
libgfortran/caf/libcaf.h
View file

@ -246,13 +246,21 @@ void _gfortran_caf_get_from_remote (
caf_token_t token, const gfc_descriptor_t *opt_src_desc,
const size_t *opt_src_charlen, const int image_index, const size_t dst_size,
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 *,

57
libgfortran/caf/single.c
View file

@ -57,19 +57,22 @@ typedef struct caf_single_token *caf_single_token_t;
/* 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;
};
@ -2862,7 +2865,7 @@ _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
}
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)
{
@ -2881,7 +2884,7 @@ _gfortran_caf_register_accessor (const int hash, accessor_t accessor)
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;
}
@ -2929,8 +2932,8 @@ _gfortran_caf_get_from_remote (
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)))
{
@ -2940,7 +2943,7 @@ _gfortran_caf_get_from_remote (
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;
@ -2953,10 +2956,10 @@ _gfortran_caf_get_from_remote (
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)
{
@ -2992,6 +2995,34 @@ _gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,
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)),