diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/coarray.cc | 157 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.texi | 34 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.cc | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 11 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 136 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 | 16 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_lib_alloc_4.f90 | 2 |
9 files changed, 268 insertions, 98 deletions
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index fb21171..c4e637e 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.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/gfortran.h b/gcc/fortran/gfortran.h index c319768..da45780 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 3337a79..b17f94c 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -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 diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index dc60d98..99d5abc 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/trans-decl.cc b/gcc/fortran/trans-decl.cc index 0a6b747..ab8ad15 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; @@ -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")), diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 1a28bfa..472acfa 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 57e2794..c0a621d 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 a423d1f..27db0e8 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 d695faa..e79ee44 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" } } |