[PATCH 4/7] 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
* 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.
* rewrite.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.
* 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.
--
Andre Vehreschild * Email: vehre ad gmx dot de
From ca929ce62d0f07b274113a20a5900d525526d25e Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Wed, 22 Jan 2025 15:12:29 +0100
Subject: [PATCH 4/7] 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
* 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.
* rewrite.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.
* 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.
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/gfortran.texi | 34 ++++
gcc/fortran/intrinsic.cc | 7 +
gcc/fortran/rewrite.cc | 157 ++++++++++++++++++
gcc/fortran/trans-decl.cc | 11 +-
gcc/fortran/trans-intrinsic.cc | 136 +++++++--------
gcc/fortran/trans.h | 2 +-
.../gfortran.dg/coarray/coarray_allocated.f90 | 16 +-
.../gfortran.dg/coarray_lib_alloc_4.f90 | 2 +-
libgfortran/caf/libcaf.h | 5 +-
libgfortran/caf/single.c | 126 +++-----------
11 files changed, 297 insertions(+), 200 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 00dcc06bd4b..c9bac84c16b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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,
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 4c3802e307a..32558e6b803 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -4211,6 +4211,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
@@ -5049,6 +5050,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
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index dc60d98d51b..99d5abcb9d5 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -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 ();
}
diff --git a/gcc/fortran/rewrite.cc b/gcc/fortran/rewrite.cc
index 3caa65c40fd..e8e791e8ada 100644
--- a/gcc/fortran/rewrite.cc
+++ b/gcc/fortran/rewrite.cc
@@ -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:
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index c22ecb4641e..c03096b1a90 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -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;
@@ -4302,10 +4302,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")),
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 1a28bfa7a58..472acfa81ca 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -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;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 57e2794ddee..c0a621df55d 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -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. */
diff --git a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
index a423d1f126e..27db0e8d8ce 100644
--- a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90
index d695faa9eaf..e79ee442be8 100644
--- a/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90
@@ -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" } }
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 4f41f5dcb67..a29047d4b23 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -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 */
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 573da1b85bf..66d3bf93e1d 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -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);
--
2.48.1
