Fortran: Add caf_is_present_on_remote. [PR107635]
Replace caf_is_present by caf_is_present_on_remote which is using a dedicated callback for each object to test on the remote image. gcc/fortran/ChangeLog: PR fortran/107635 * coarray.cc (create_allocated_callback): Add creating remote side procedure for checking allocation status of coarray. (rewrite_caf_allocated): Rewrite ALLOCATED on coarray to use caf routine. (coindexed_expr_callback): Exempt caf_is_present_on_remote from being rewritten again. * gfortran.h (enum gfc_isym_id): Add caf_is_present_on_remote id. * gfortran.texi: Add documentation for caf_is_present_on_remote. * intrinsic.cc (add_functions): Add caf_is_present_on_remote symbol. * trans-decl.cc (gfc_build_builtin_function_decls): Define interface of caf_is_present_on_remote. * trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote): Translate caf_is_present_on_remote. (trans_caf_is_present): Remove. (caf_this_image_ref): Remove. (gfc_conv_allocated): Take out coarray treatment, because that is rewritten to caf_is_present_on_remote now. (gfc_conv_intrinsic_function): Handle caf_is_present_on_remote calls. * trans.h: Add symbol for caf_is_present_on_remote and remove old one. libgfortran/ChangeLog: * caf/libcaf.h (_gfortran_caf_is_present_on_remote): Add new function. (_gfortran_caf_is_present): Remove deprecated one. * caf/single.c (struct accessor_hash_t): Add function ptr access for remote side call. (_gfortran_caf_is_present_on_remote): Added. (_gfortran_caf_is_present): Removed. gcc/testsuite/ChangeLog: * gfortran.dg/coarray/coarray_allocated.f90: Adapt to new method of checking on remote image. * gfortran.dg/coarray_lib_alloc_4.f90: Same.
This commit is contained in:
Andre Vehreschild
parent
abbfeb2ecb
commit
1584725264
11 changed files with 297 additions and 200 deletions
|
|
@ -942,6 +942,154 @@ add_caf_get_from_remote (gfc_expr *e)
|
|||
free (wrapper);
|
||||
}
|
||||
|
||||
static gfc_expr *
|
||||
create_allocated_callback (gfc_expr *expr)
|
||||
{
|
||||
gfc_namespace *ns;
|
||||
gfc_symbol *extproc, *proc, *result, *base, *add_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;
|
||||
gfc_expr swp;
|
||||
|
||||
/* Find the top-level namespace. */
|
||||
for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
|
||||
;
|
||||
|
||||
if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
|
||||
strcpy (tname, expr->value.function.actual->expr->symtree->name);
|
||||
else
|
||||
strcpy (tname, "dummy");
|
||||
if (expr->value.function.actual->expr->symtree->n.sym->module)
|
||||
mname = expr->value.function.actual->expr->symtree->n.sym->module;
|
||||
else
|
||||
mname = "main";
|
||||
name = xasprintf ("_caf_present_%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->declared_at = expr->where;
|
||||
++proc->refs;
|
||||
gfc_commit_symbol (proc);
|
||||
free (name);
|
||||
|
||||
split_expr_at_caf_ref (expr->value.function.actual->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, 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_data_%s_%s_%d", mname, tname, ++caf_sym_cnt);
|
||||
ADD_ARG (name, add_data, BT_DERIVED, 0, INTENT_IN);
|
||||
gfc_commit_symbol (add_data);
|
||||
free (name);
|
||||
ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
|
||||
INTENT_IN);
|
||||
gfc_commit_symbol (caller_image);
|
||||
|
||||
ADD_ARG ("result", result, BT_LOGICAL, gfc_default_logical_kind, INTENT_OUT);
|
||||
gfc_commit_symbol (result);
|
||||
|
||||
// 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);
|
||||
#undef ADD_ARG
|
||||
|
||||
/* Set up code. */
|
||||
/* Code: result = post_caf_ref_expr; */
|
||||
code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
|
||||
code->loc = expr->where;
|
||||
code->expr1 = gfc_lval_expr_from_sym (result);
|
||||
swp = *expr;
|
||||
*expr = *swp.value.function.actual->expr;
|
||||
swp.value.function.actual->expr = nullptr;
|
||||
code->expr2 = gfc_copy_expr (&swp);
|
||||
code->expr2->value.function.actual->expr = post_caf_ref_expr;
|
||||
|
||||
remove_caf_ref (code->expr2->value.function.actual->expr, true);
|
||||
add_data->ts.u.derived
|
||||
= create_caf_add_data_parameter_type (post_caf_ref_expr, ns, add_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_allocated (gfc_expr **e)
|
||||
{
|
||||
gfc_expr *present_fn_expr, *present_hash_expr, *wrapper;
|
||||
|
||||
present_fn_expr = create_allocated_callback (*e);
|
||||
|
||||
present_hash_expr = gfc_get_expr ();
|
||||
present_hash_expr->expr_type = EXPR_CONSTANT;
|
||||
present_hash_expr->ts.type = BT_INTEGER;
|
||||
present_hash_expr->ts.kind = gfc_default_integer_kind;
|
||||
present_hash_expr->where = (*e)->where;
|
||||
mpz_init_set_ui (present_hash_expr->value.integer,
|
||||
gfc_hash_value (present_fn_expr->symtree->n.sym));
|
||||
wrapper
|
||||
= gfc_build_intrinsic_call (gfc_current_ns,
|
||||
GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
|
||||
"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 int
|
||||
coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
|
||||
void *data ATTRIBUTE_UNUSED)
|
||||
|
|
@ -963,7 +1111,16 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
|
|||
if ((*e)->value.function.isym)
|
||||
switch ((*e)->value.function.isym->id)
|
||||
{
|
||||
case GFC_ISYM_ALLOCATED:
|
||||
if ((*e)->value.function.actual->expr
|
||||
&& gfc_is_coindexed ((*e)->value.function.actual->expr))
|
||||
{
|
||||
rewrite_caf_allocated (e);
|
||||
*walk_subtrees = 0;
|
||||
}
|
||||
break;
|
||||
case GFC_ISYM_CAF_GET:
|
||||
case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
|
||||
*walk_subtrees = 0;
|
||||
break;
|
||||
default:
|
||||
|
|
|
|||
|
|
@ -456,6 +456,7 @@ enum gfc_isym_id
|
|||
GFC_ISYM_BLT,
|
||||
GFC_ISYM_BTEST,
|
||||
GFC_ISYM_CAF_GET,
|
||||
GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
|
||||
GFC_ISYM_CAF_SEND,
|
||||
GFC_ISYM_CEILING,
|
||||
GFC_ISYM_CHAR,
|
||||
|
|
|
|||
|
|
@ -4212,6 +4212,7 @@ future implementation of teams. It is about to change without further notice.
|
|||
* _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_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_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
|
||||
|
|
@ -5050,6 +5051,39 @@ implementation has to take care that it handles this case, e.g. using
|
|||
@end table
|
||||
|
||||
|
||||
@node _gfortran_caf_is_present_on_remote
|
||||
@subsection @code{_gfortran_caf_is_present_on_remote} --- Check that a coarray or a part of it is allocated on the remote image
|
||||
@cindex Coarray, _gfortran_caf_is_present_on_remote
|
||||
|
||||
@table @asis
|
||||
@item @emph{Description}:
|
||||
Check if an allocatable coarray or a component of a derived type coarray is
|
||||
allocated on the remote image identified by the @var{image_index}. The check
|
||||
is done by calling routine on the remote side.
|
||||
|
||||
@item @emph{Syntax}:
|
||||
@code{int32_t _gfortran_caf_is_present_on_remote (caf_token_t token,
|
||||
const int image_index, const int is_present_index, void *add_data,
|
||||
const size_t add_data_size)}
|
||||
|
||||
@item @emph{Arguments}:
|
||||
@multitable @columnfractions .15 .70
|
||||
@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
|
||||
@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{is_present_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.
|
||||
@end multitable
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -3521,6 +3521,13 @@ add_functions (void)
|
|||
BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL,
|
||||
x, BT_REAL, dr, REQUIRED);
|
||||
make_from_module();
|
||||
|
||||
add_sym_3 (GFC_PREFIX ("caf_is_present_on_remote"),
|
||||
GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE, CLASS_IMPURE, ACTUAL_NO,
|
||||
BT_LOGICAL, dl, GFC_STD_GNU, NULL, NULL, NULL, ca, BT_VOID, di,
|
||||
REQUIRED, val, BT_INTEGER, di, REQUIRED, i, BT_INTEGER, di,
|
||||
REQUIRED);
|
||||
make_from_module ();
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -180,7 +180,7 @@ tree gfor_fndecl_co_max;
|
|||
tree gfor_fndecl_co_min;
|
||||
tree gfor_fndecl_co_reduce;
|
||||
tree gfor_fndecl_co_sum;
|
||||
tree gfor_fndecl_caf_is_present;
|
||||
tree gfor_fndecl_caf_is_present_on_remote;
|
||||
tree gfor_fndecl_caf_random_init;
|
||||
|
||||
|
||||
|
|
@ -4300,10 +4300,11 @@ gfc_build_builtin_function_decls (void)
|
|||
void_type_node, 5, pvoid_type_node, integer_type_node,
|
||||
pint_type, pchar_type_node, size_type_node);
|
||||
|
||||
gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec (
|
||||
get_identifier (PREFIX("caf_is_present")), ". r . r ",
|
||||
integer_type_node, 3, pvoid_type_node, integer_type_node,
|
||||
pvoid_type_node);
|
||||
gfor_fndecl_caf_is_present_on_remote
|
||||
= gfc_build_library_function_decl_with_spec (
|
||||
get_identifier (PREFIX ("caf_is_present_on_remote")), ". r r r r r ",
|
||||
integer_type_node, 5, pvoid_type_node, integer_type_node,
|
||||
integer_type_node, pvoid_type_node, size_type_node);
|
||||
|
||||
gfor_fndecl_caf_random_init = gfc_build_library_function_decl (
|
||||
get_identifier (PREFIX("caf_random_init")),
|
||||
|
|
|
|||
|
|
@ -1966,6 +1966,46 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
|
|||
return;
|
||||
}
|
||||
|
||||
/* Generate call to caf_is_present_on_remote for allocated (coarrary[...])
|
||||
calls. */
|
||||
|
||||
static void
|
||||
gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e)
|
||||
{
|
||||
gfc_expr *caf_expr, *hash, *present_fn;
|
||||
gfc_symbol *add_data_sym;
|
||||
tree fn_index, add_data_tree, add_data_size, caf_decl, image_index, token;
|
||||
|
||||
gcc_assert (e->expr_type == EXPR_FUNCTION
|
||||
&& e->value.function.isym->id
|
||||
== GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE);
|
||||
caf_expr = e->value.function.actual->expr;
|
||||
hash = e->value.function.actual->next->expr;
|
||||
present_fn = e->value.function.actual->next->next->expr;
|
||||
add_data_sym = present_fn->symtree->n.sym->formal->sym;
|
||||
|
||||
fn_index = conv_caf_func_index (&se->pre, gfc_current_ns,
|
||||
"__caf_present_on_remote_fn_index_%d", hash);
|
||||
add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns,
|
||||
"__caf_present_on_remote_add_data_%d",
|
||||
add_data_sym, &add_data_size);
|
||||
++caf_call_cnt;
|
||||
|
||||
caf_decl = gfc_get_tree_for_caf_expr (caf_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, caf_expr, caf_decl);
|
||||
gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL, caf_expr);
|
||||
|
||||
se->expr
|
||||
= fold_convert (logical_type_node,
|
||||
build_call_expr_loc (input_location,
|
||||
gfor_fndecl_caf_is_present_on_remote,
|
||||
5, token, image_index, fn_index,
|
||||
add_data_tree, add_data_size));
|
||||
}
|
||||
|
||||
static bool
|
||||
has_ref_after_cafref (gfc_expr *expr)
|
||||
{
|
||||
|
|
@ -9498,42 +9538,6 @@ scalar_transfer:
|
|||
}
|
||||
|
||||
|
||||
/* Generate a call to caf_is_present. */
|
||||
|
||||
static tree
|
||||
trans_caf_is_present (gfc_se *se, gfc_expr *expr)
|
||||
{
|
||||
tree caf_reference, caf_decl, token, image_index;
|
||||
|
||||
/* Compile the reference chain. */
|
||||
caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
|
||||
gcc_assert (caf_reference != NULL_TREE);
|
||||
|
||||
caf_decl = gfc_get_tree_for_caf_expr (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, expr, caf_decl);
|
||||
gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
|
||||
expr);
|
||||
|
||||
return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
|
||||
3, token, image_index, caf_reference);
|
||||
}
|
||||
|
||||
|
||||
/* Test whether this ref-chain refs this image only. */
|
||||
|
||||
static bool
|
||||
caf_this_image_ref (gfc_ref *ref)
|
||||
{
|
||||
for ( ; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen)
|
||||
return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
|
||||
|
||||
return false;
|
||||
}
|
||||
|
||||
|
||||
/* Generate code for the ALLOCATED intrinsic.
|
||||
Generate inline code that directly check the address of the argument. */
|
||||
|
||||
|
|
@ -9542,7 +9546,6 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
|
|||
{
|
||||
gfc_se arg1se;
|
||||
tree tmp;
|
||||
bool coindexed_caf_comp = false;
|
||||
gfc_expr *e = expr->value.function.actual->expr;
|
||||
|
||||
gfc_init_se (&arg1se, NULL);
|
||||
|
|
@ -9557,53 +9560,26 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
|
|||
gfc_add_data_component (e);
|
||||
}
|
||||
|
||||
/* When 'e' references an allocatable component in a coarray, then call
|
||||
the caf-library function caf_is_present (). */
|
||||
if (flag_coarray == GFC_FCOARRAY_LIB && e->expr_type == EXPR_FUNCTION
|
||||
&& e->value.function.isym
|
||||
&& e->value.function.isym->id == GFC_ISYM_CAF_GET)
|
||||
gcc_assert (flag_coarray != GFC_FCOARRAY_LIB || !gfc_is_coindexed (e));
|
||||
|
||||
if (e->rank == 0)
|
||||
{
|
||||
e = e->value.function.actual->expr;
|
||||
if (gfc_expr_attr (e).codimension)
|
||||
{
|
||||
/* Last partref is the coindexed coarray. As coarrays are collectively
|
||||
(de)allocated, the allocation status must be the same as the one of
|
||||
the local allocation. Convert to local access. */
|
||||
for (gfc_ref *ref = e->ref; ref; ref = ref->next)
|
||||
if (ref->type == REF_ARRAY && ref->u.ar.codimen)
|
||||
{
|
||||
for (int i = ref->u.ar.dimen;
|
||||
i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
|
||||
ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
|
||||
break;
|
||||
}
|
||||
}
|
||||
else if (!caf_this_image_ref (e->ref))
|
||||
coindexed_caf_comp = true;
|
||||
/* Allocatable scalar. */
|
||||
arg1se.want_pointer = 1;
|
||||
gfc_conv_expr (&arg1se, e);
|
||||
tmp = arg1se.expr;
|
||||
}
|
||||
if (coindexed_caf_comp)
|
||||
tmp = trans_caf_is_present (se, e);
|
||||
else
|
||||
{
|
||||
if (e->rank == 0)
|
||||
{
|
||||
/* Allocatable scalar. */
|
||||
arg1se.want_pointer = 1;
|
||||
gfc_conv_expr (&arg1se, e);
|
||||
tmp = arg1se.expr;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Allocatable array. */
|
||||
arg1se.descriptor_only = 1;
|
||||
gfc_conv_expr_descriptor (&arg1se, e);
|
||||
tmp = gfc_conv_descriptor_data_get (arg1se.expr);
|
||||
}
|
||||
|
||||
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
|
||||
fold_convert (TREE_TYPE (tmp), null_pointer_node));
|
||||
/* Allocatable array. */
|
||||
arg1se.descriptor_only = 1;
|
||||
gfc_conv_expr_descriptor (&arg1se, e);
|
||||
tmp = gfc_conv_descriptor_data_get (arg1se.expr);
|
||||
}
|
||||
|
||||
tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
|
||||
fold_convert (TREE_TYPE (tmp), null_pointer_node));
|
||||
|
||||
/* Components of pointer array references sometimes come back with a pre block. */
|
||||
if (arg1se.pre.head)
|
||||
gfc_add_block_to_block (&se->pre, &arg1se.pre);
|
||||
|
|
@ -11718,6 +11694,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, false, NULL);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
|
||||
gfc_conv_intrinsic_caf_is_present_remote (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_CMPLX:
|
||||
gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -928,7 +928,7 @@ extern GTY(()) tree gfor_fndecl_co_max;
|
|||
extern GTY(()) tree gfor_fndecl_co_min;
|
||||
extern GTY(()) tree gfor_fndecl_co_reduce;
|
||||
extern GTY(()) tree gfor_fndecl_co_sum;
|
||||
extern GTY(()) tree gfor_fndecl_caf_is_present;
|
||||
extern GTY(()) tree gfor_fndecl_caf_is_present_on_remote;
|
||||
|
||||
/* Math functions. Many other math functions are handled in
|
||||
trans-intrinsic.cc. */
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ program p
|
|||
if (.not. allocated (a[1])) stop 7
|
||||
if (.not. allocated (c%x[1,2,3])) stop 8
|
||||
|
||||
! Dellocate collectively
|
||||
! Deallocate collectively
|
||||
deallocate(a)
|
||||
deallocate(c%x)
|
||||
|
||||
|
|
@ -40,16 +40,6 @@ program p
|
|||
if (allocated (c%x[1,2,3])) stop 12
|
||||
end
|
||||
|
||||
! twice == 0 for .not. allocated' (coindexed vs. not)
|
||||
! four times != for allocated (before alloc after dealloc, coindexed and not)
|
||||
|
||||
! There are also == 0 and != 0 for (de)allocate checks with -fcoarray=single but those
|
||||
! aren't prefixed by '(integer(kind=4) *)'
|
||||
|
||||
! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) a.data != 0B" 4 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) c.x.data != 0B" 4 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) a.data == 0B" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) c.x.data == 0B" 2 "original" } }
|
||||
|
||||
! Expected: always local access and never a call to _gfortran_caf_get
|
||||
! { dg-final { scan-tree-dump-not "caf_get" "original" } }
|
||||
! { dg-final { scan-tree-dump-not "caf_get " "original" } }
|
||||
! { dg-final { scan-tree-dump-not "caf_get_by_" "original" } }
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ program test_caf_alloc
|
|||
deallocate(xx)
|
||||
end
|
||||
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_caf_is_present \\(xx\\.token, \\(integer\\(kind=4\\)\\) \\(2 - xx\\.dim\\\[0\\\]\\.lbound\\), &caf_ref\\.\[0-9\]+\\)|_gfortran_caf_is_present \\(xx\\.token, 2 - xx\\.dim\\\[0\\\]\\.lbound, &caf_ref\\.\[0-9\]+\\)" 10 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_caf_is_present_on_remote" 10 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 1, &xx\\.token, \\(void \\*\\) &xx, 0B, 0B, 0\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 7" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 8" 2 "original" } }
|
||||
|
|
|
|||
|
|
@ -249,6 +249,9 @@ void _gfortran_caf_get_from_remote (
|
|||
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);
|
||||
|
||||
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_atomic_define (caf_token_t, size_t, int, void *, int *,
|
||||
int, int);
|
||||
|
|
@ -272,8 +275,6 @@ void _gfortran_caf_stopped_images (gfc_descriptor_t *,
|
|||
caf_team_t * __attribute__ ((unused)),
|
||||
int *);
|
||||
|
||||
int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
|
||||
|
||||
void _gfortran_caf_random_init (bool, bool);
|
||||
|
||||
#endif /* LIBCAF_H */
|
||||
|
|
|
|||
|
|
@ -60,6 +60,8 @@ 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 (*is_present_t) (void *, const int *, int32_t *, void *,
|
||||
caf_single_token_t, const size_t);
|
||||
struct accessor_hash_t
|
||||
{
|
||||
int hash;
|
||||
|
|
@ -67,6 +69,7 @@ struct accessor_hash_t
|
|||
union
|
||||
{
|
||||
accessor_t accessor;
|
||||
is_present_t is_present;
|
||||
} u;
|
||||
};
|
||||
|
||||
|
|
@ -2966,6 +2969,29 @@ _gfortran_caf_get_from_remote (
|
|||
}
|
||||
}
|
||||
|
||||
int32_t
|
||||
_gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,
|
||||
const int present_index, void *add_data,
|
||||
const size_t add_data_size
|
||||
__attribute__ ((unused)))
|
||||
{
|
||||
/* Unregistered tokens are always not present. */
|
||||
if (!token)
|
||||
return 0;
|
||||
|
||||
caf_single_token_t single_token = TOKEN (token);
|
||||
int32_t result;
|
||||
struct caf_single_token cb_token = {add_data, NULL, false};
|
||||
|
||||
|
||||
accessor_hash_table[present_index].u.is_present (add_data, &image_index,
|
||||
&result,
|
||||
single_token->memptr,
|
||||
&cb_token, 0);
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
void
|
||||
_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
|
||||
int image_index __attribute__ ((unused)),
|
||||
|
|
@ -3174,106 +3200,6 @@ _gfortran_caf_unlock (caf_token_t token, size_t index,
|
|||
_gfortran_caf_error_stop_str (msg, strlen (msg), false);
|
||||
}
|
||||
|
||||
int
|
||||
_gfortran_caf_is_present (caf_token_t token,
|
||||
int image_index __attribute__ ((unused)),
|
||||
caf_reference_t *refs)
|
||||
{
|
||||
const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
|
||||
"only scalar indexes allowed.\n";
|
||||
const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
|
||||
"unknown reference type.\n";
|
||||
const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
|
||||
"unknown array reference type.\n";
|
||||
size_t i;
|
||||
caf_single_token_t single_token = TOKEN (token);
|
||||
void *memptr = single_token->memptr;
|
||||
gfc_descriptor_t *src = single_token->desc;
|
||||
caf_reference_t *riter = refs;
|
||||
|
||||
while (riter)
|
||||
{
|
||||
switch (riter->type)
|
||||
{
|
||||
case CAF_REF_COMPONENT:
|
||||
if (riter->u.c.caf_token_offset)
|
||||
{
|
||||
single_token = *(caf_single_token_t*)
|
||||
(memptr + riter->u.c.caf_token_offset);
|
||||
memptr = single_token->memptr;
|
||||
src = single_token->desc;
|
||||
}
|
||||
else
|
||||
{
|
||||
memptr += riter->u.c.offset;
|
||||
src = (gfc_descriptor_t *)memptr;
|
||||
}
|
||||
break;
|
||||
case CAF_REF_ARRAY:
|
||||
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
|
||||
{
|
||||
switch (riter->u.a.mode[i])
|
||||
{
|
||||
case CAF_ARR_REF_SINGLE:
|
||||
memptr += (riter->u.a.dim[i].s.start
|
||||
- GFC_DIMENSION_LBOUND (src->dim[i]))
|
||||
* GFC_DIMENSION_STRIDE (src->dim[i])
|
||||
* riter->item_size;
|
||||
break;
|
||||
case CAF_ARR_REF_FULL:
|
||||
/* A full array ref is allowed on the last reference only. */
|
||||
if (riter->next == NULL)
|
||||
break;
|
||||
/* else fall through reporting an error. */
|
||||
/* FALLTHROUGH */
|
||||
case CAF_ARR_REF_VECTOR:
|
||||
case CAF_ARR_REF_RANGE:
|
||||
case CAF_ARR_REF_OPEN_END:
|
||||
case CAF_ARR_REF_OPEN_START:
|
||||
caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
|
||||
return 0;
|
||||
default:
|
||||
caf_internal_error (unknownarrreftype, 0, NULL, 0);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
break;
|
||||
case CAF_REF_STATIC_ARRAY:
|
||||
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
|
||||
{
|
||||
switch (riter->u.a.mode[i])
|
||||
{
|
||||
case CAF_ARR_REF_SINGLE:
|
||||
memptr += riter->u.a.dim[i].s.start
|
||||
* riter->u.a.dim[i].s.stride
|
||||
* riter->item_size;
|
||||
break;
|
||||
case CAF_ARR_REF_FULL:
|
||||
/* A full array ref is allowed on the last reference only. */
|
||||
if (riter->next == NULL)
|
||||
break;
|
||||
/* else fall through reporting an error. */
|
||||
/* FALLTHROUGH */
|
||||
case CAF_ARR_REF_VECTOR:
|
||||
case CAF_ARR_REF_RANGE:
|
||||
case CAF_ARR_REF_OPEN_END:
|
||||
case CAF_ARR_REF_OPEN_START:
|
||||
caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
|
||||
return 0;
|
||||
default:
|
||||
caf_internal_error (unknownarrreftype, 0, NULL, 0);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
break;
|
||||
default:
|
||||
caf_internal_error (unknownreftype, 0, NULL, 0);
|
||||
return 0;
|
||||
}
|
||||
riter = riter->next;
|
||||
}
|
||||
return memptr != NULL;
|
||||
}
|
||||
|
||||
/* Reference the libraries implementation. */
|
||||
extern void _gfortran_random_init (int32_t, int32_t, int32_t);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue