[gcc r17-3342] fortran: [PR53800] Wrong copy-in/out with array actual to TARGET dummy
Jerry DeLisle via Gcc-cvs <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:f3943597388db4846386b6d5a18d33ebf80ea96c commit r17-3342-gf3943597388db4846386b6d5a18d33ebf80ea96c Author: Jerry DeLisle <[email protected]> Date: Mon Aug 10 09:37:01 2026 -0700 fortran: [PR53800] Wrong copy-in/out with array actual to TARGET dummy An actual argument whose elements are spaced by more than the element size - a CLASS array, or a component of a derived-type array - was copied in and out when passed to a TARGET or POINTER dummy, so pointers associated with the dummy went stale on return. Such an actual argument is now passed with a descriptor of its own, whose element type is that of the subobject and whose span is the element size of the array, as is already done for a pointer assignment to a subobject of an array. The dummy addresses its elements through that span. Passing it on to a dummy that requires contiguous storage copies it, but only if it turns out not to be contiguous. PR fortran/53800 gcc/fortran/ChangeLog: * gfortran.h (gfc_is_span_addressed_dummy): New prototype. * symbol.cc (gfc_is_span_addressed_dummy): New function. * expr.cc (is_subref_array): Return true for a span addressed dummy. * trans.h (gfc_get_span_descriptor): New prototype. * trans.cc (gfc_get_span_descriptor): New function returning the descriptor that carries a pointer array decl's span. (get_array_span): Use it, including for character types. * trans-array.cc (is_pointer_array): Note in the comment that the tree must be a descriptor. (span_addressed_array): New function returning the decl that provides the span of an array. (gfc_get_array_span): Use it. (gfc_conv_scalarized_array_ref, gfc_conv_array_ref): Likewise, so that a descriptorless dummy is addressed by its span. (gfc_get_dataptr_offset): Likewise and dereference a spanned character element. (gfc_conv_expr_descriptor): Describe a subobject of the array elements by a new descriptor when no temporary is made. * trans-decl.cc (gfc_build_dummy_array_decl): Use gfc_is_span_addressed_dummy to mark the dummy as a pointer array. (gfc_get_symbol_decl): Likewise. * trans-expr.cc (is_subobject_ref): New function. (copy_in_out_allowed): Take the actual argument. Use gfc_is_span_addressed_dummy and keep the copy for an actual argument with a vector subscript. (gfc_conv_gfc_desc_to_cfi_desc): Remove the now duplicate offsetting of the data pointer for a subobject reference. (gfc_class_array_data_assign): Also copy the span field. (gfc_conv_procedure_call): Use copy_in_out_allowed to skip copy-in/copy-out for a class array reference, a class array function result and a subref array. Pass a spanned descriptor instead and make the copy of a span addressed dummy conditional on it not being contiguous. * trans-intrinsic.cc (gfc_conv_is_contiguous_expr): Check the span of a span addressed dummy against the element length. gcc/testsuite/ChangeLog: * gfortran.dg/c_loc_test_22.f90: Update dump patterns for span addressing. * gfortran.dg/class_to_type_5.f90: New test. * gfortran.dg/class_to_type_6.f90: New test. * gfortran.dg/class_to_type_7.f90: New test. * gfortran.dg/class_to_type_8.f90: New test. * gfortran.dg/class_to_type_9.f90: New test. libgomp/ChangeLog: * testsuite/libgomp.oacc-fortran/host_data-5.F90: Update the privatization notes for the packing of a TARGET dummy. Diff: --- gcc/fortran/expr.cc | 3 +- gcc/fortran/gfortran.h | 1 + gcc/fortran/symbol.cc | 24 ++++ gcc/fortran/trans-array.cc | 69 +++++++--- gcc/fortran/trans-decl.cc | 22 ++- gcc/fortran/trans-expr.cc | 92 ++++++++++--- gcc/fortran/trans-intrinsic.cc | 7 +- gcc/fortran/trans.cc | 31 ++++- gcc/fortran/trans.h | 3 + gcc/testsuite/gfortran.dg/c_loc_test_22.f90 | 6 +- gcc/testsuite/gfortran.dg/class_to_type_5.f90 | 35 +++++ gcc/testsuite/gfortran.dg/class_to_type_6.f90 | 93 +++++++++++++ gcc/testsuite/gfortran.dg/class_to_type_7.f90 | 151 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/class_to_type_8.f90 | 47 +++++++ gcc/testsuite/gfortran.dg/class_to_type_9.f90 | 67 +++++++++ .../testsuite/libgomp.oacc-fortran/host_data-5.F90 | 15 +- 16 files changed, 612 insertions(+), 54 deletions(-) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 20eddbefd57d..52945a1db136 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -1222,7 +1222,8 @@ is_subref_array (gfc_expr * e) sym = e->symtree->n.sym; - if (sym->attr.subref_array_pointer) + if (sym->attr.subref_array_pointer + || gfc_is_span_addressed_dummy (sym)) return true; seen_array = false; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b7272de58c89..53e239f21a48 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3975,6 +3975,7 @@ bool gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); gfc_namespace* gfc_find_proc_namespace (gfc_namespace*); bool gfc_is_associate_pointer (gfc_symbol*); +bool gfc_is_span_addressed_dummy (gfc_symbol *); gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *); gfc_formal_arglist *gfc_sym_get_dummy_args (gfc_symbol *); diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index 36e1262fff5a..dde3e92a33d3 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5702,6 +5702,30 @@ gfc_is_associate_pointer (gfc_symbol* sym) } +/* Check if a dummy argument must be addressed using the span of its + descriptor. The actual argument of an assumed shape or assumed rank + TARGET dummy is never copied, so its elements can be spaced by more + than the element size. CLASS and assumed type entities already carry + their element size and are excluded. */ + +bool +gfc_is_span_addressed_dummy (gfc_symbol *sym) +{ + return sym->attr.dummy + && sym->attr.target + && sym->attr.dimension + && !sym->attr.value + && !sym->attr.contiguous + && !sym->attr.pointer + && !sym->attr.allocatable + && sym->ts.type != BT_CLASS + && sym->ts.type != BT_ASSUMED + && sym->as + && (sym->as->type == AS_ASSUMED_SHAPE + || sym->as->type == AS_ASSUMED_RANK); +} + + gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *sym) { diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index b5346b85be77..2f11b61a4b81 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -458,7 +458,8 @@ gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) } -/* Returns true if the expression is an array pointer. */ +/* Returns true if the expression is an array pointer. The tree must be a + descriptor. */ static bool is_pointer_array (tree expr) @@ -480,7 +481,7 @@ is_pointer_array (tree expr) && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) return true; - /* The field declaration is marked as an pointer array. */ + /* The field declaration is marked as a pointer array. */ if (TREE_CODE (expr) == COMPONENT_REF && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) @@ -490,6 +491,29 @@ is_pointer_array (tree expr) } +/* If the elements of the array are spaced by the span of its descriptor, + return the decl that provides that span, otherwise NULL_TREE. This is + either a descriptor or the local decl of a descriptorless dummy array, + which keeps the descriptor it was built from as the saved one. */ + +static tree +span_addressed_array (tree expr) +{ + if (is_pointer_array (expr)) + return expr; + + if (VAR_P (expr) + && GFC_DECL_PTR_ARRAY_P (expr) + && !GFC_DECL_CLASS (expr) + && GFC_ARRAY_TYPE_P (TREE_TYPE (expr)) + && DECL_LANG_SPECIFIC (expr) + && GFC_DECL_SAVED_DESCRIPTOR (expr)) + return expr; + + return NULL_TREE; +} + + /* If the symbol or expression reference a CFI descriptor, return the pointer to the converted gfc descriptor. If an array reference is present as the last argument, check that it is the one applied to @@ -554,18 +578,13 @@ gfc_get_array_span (tree desc, gfc_expr *expr) gfc_symbol *sym = (expr && expr->expr_type == EXPR_VARIABLE) ? expr->symtree->n.sym : NULL; - if (is_pointer_array (desc) + if (span_addressed_array (desc) || (get_CFI_desc (NULL, expr, &desc, NULL) && (POINTER_TYPE_P (TREE_TYPE (desc)) ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc))) : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))))) - { - if (POINTER_TYPE_P (TREE_TYPE (desc))) - desc = build_fold_indirect_ref_loc (input_location, desc); - - /* This will have the span field set. */ - tmp = gfc_conv_descriptor_span_get (desc); - } + /* This will have the span field set. */ + tmp = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (desc)); else if (expr->ts.type == BT_ASSUMED) { if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc)) @@ -3964,7 +3983,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, /* A pointer array component can be detected from its field decl. Fix the descriptor, mark the resulting variable decl and pass it to gfc_build_array_ref. */ - if (is_pointer_array (info->descriptor) + if (span_addressed_array (info->descriptor) || (expr && expr->ts.deferred && info->descriptor && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor)))) { @@ -4217,11 +4236,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, if (get_CFI_desc (sym, expr, &decl, ar)) decl = build_fold_indirect_ref_loc (input_location, decl); if (!expr->ts.deferred && !sym->attr.codimension - && is_pointer_array (se->expr)) + && span_addressed_array (se->expr)) { - if (TREE_CODE (se->expr) == COMPONENT_REF) - decl = se->expr; - else if (INDIRECT_REF_P (se->expr)) + if (INDIRECT_REF_P (se->expr)) decl = TREE_OPERAND (se->expr, 0); else decl = se->expr; @@ -7595,7 +7612,13 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset, return; } - tmp = build_array_ref (desc, offset, NULL, NULL); + /* An array whose elements are spaced by the span needs pointer arithmetic + to reference an element. */ + tmp = build_array_ref (desc, offset, span_addressed_array (desc), NULL); + + /* A spanned character element is referenced by a pointer. */ + if (POINTER_TYPE_P (TREE_TYPE (tmp)) && span_addressed_array (desc)) + tmp = build_fold_indirect_ref_loc (input_location, tmp); /* Offset the data pointer for pointer assignments from arrays with subreferences; e.g. my_integer => my_type(:)%integer_component. */ @@ -8058,6 +8081,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) subref_array_target = (is_subref_array (expr) && (se->direct_byref + || se->force_no_tmp || expr->ts.type == BT_CHARACTER)); need_tmp = (gfc_ref_needs_temporary_p (expr->ref) && !subref_array_target); @@ -8087,6 +8111,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else full = gfc_full_array_ref_p (info->ref, NULL); + /* A subobject of the array elements is described by a new descriptor, + whose element type is that of the subobject and whose span is the + element size of the array. */ + if (subref_array_target && !se->direct_byref + && info->ref && info->ref->next) + full = 0; + if (full && !transposed_dims (ss)) { if (se->direct_byref && !se->byref_noassign) @@ -8408,8 +8439,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } else { - /* Otherwise make a new one. */ - if (expr->ts.type == BT_CHARACTER) + /* Otherwise make a new one. The element type is that of the + subobject for a subreference of the array. */ + if (expr->ts.type == BT_CHARACTER + || (subref_array_target && !se->direct_byref)) parmtype = gfc_typenode_for_spec (&expr->ts); else parmtype = gfc_get_element_type (TREE_TYPE (desc)); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 5678f69df9ca..1d85e5b94cdf 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -1406,6 +1406,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy; + /* The elements of the actual argument can be spaced by more than the + element size, so the span of the descriptor is used to address them. */ + if (gfc_is_span_addressed_dummy (sym) && packed == PACKED_NO) + GFC_DECL_PTR_ARRAY_P (decl) = 1; + if (sym->ns->proc_name->backend_decl == current_function_decl || sym->attr.contained) gfc_add_decl_to_function (decl); @@ -1784,7 +1789,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) && sym->attr.allocatable) gfc_defer_symbol_init (sym); - if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) + if ((sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) + || gfc_is_span_addressed_dummy (sym)) GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; /* Create a character length variable. */ @@ -2079,6 +2085,20 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !sym->attr.subref_array_pointer)) GFC_DECL_PTR_ARRAY_P (decl) = 1; + /* A SELECT RANK temporary uses a copy of the selector's descriptor. + Its elements may be spaced by more than the element size, + so use copied span as well. */ + if (sym->attr.select_rank_temporary && sym->attr.dimension + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + && sym->assoc && sym->assoc->target + && sym->assoc->target->expr_type == EXPR_VARIABLE) + { + gfc_symbol *sel = sym->assoc->target->symtree->n.sym; + if (!sel->attr.contiguous + && (sel->attr.target || sel->attr.pointer || sel->ts.type == BT_CLASS)) + GFC_DECL_PTR_ARRAY_P (decl) = 1; + } + if (sym->ts.type == BT_CLASS) GFC_DECL_CLASS(decl) = 1; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7656f9784dd0..51bb943f9ff2 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -837,6 +837,8 @@ gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, gfc_conv_descriptor_dtype_set (block, lhs_desc, gfc_conv_descriptor_dtype_get (rhs_desc)); + gfc_conv_descriptor_span_set (block, lhs_desc, + gfc_conv_descriptor_span_get (rhs_desc)); /* Assign the dimension as range-ref. */ lhs_dim = gfc_get_descriptor_dimension (lhs_desc); @@ -6233,14 +6235,12 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) else gfc_conv_expr_descriptor (&se, e); gfc = se.expr; - /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses - elem_len = sizeof(dt) and base_addr = dt(lb) instead. - gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below. - While sm is fine as it uses span*stride and not elem_len. */ + /* For dt(:)%var, the base_addr is that of the subobject and elem_len is + its size, see below. The descriptor built for a subreference of the + array provides both. While sm is fine as it uses span*stride and not + elem_len. */ if (POINTER_TYPE_P (TREE_TYPE (gfc))) gfc = build_fold_indirect_ref_loc (input_location, gfc); - else if (is_subref_array (e) && e->ts.type != BT_CHARACTER) - gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e); } if (e->ts.type == BT_CHARACTER) { @@ -6954,6 +6954,48 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym) } +/* Return true if a subobject of the elements of an array is referenced. */ + +static bool +is_subobject_ref (gfc_expr *e) +{ + bool seen_array = false; + + for (gfc_ref *ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + seen_array = true; + else if (seen_array) + return true; + } + + return false; +} + + +/* Return true if the actual argument E for the dummy FSYM may be passed as a + copy-in/copy-out temporary. A pointer associated with a TARGET or POINTER + dummy must remain valid after the call, so the actual argument is passed + directly, with a descriptor whose span provides the element spacing. An + actual argument with a vector subscript is not definable and its pointer + association is undefined on return, so it is still copied. */ + +static bool +copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg) +{ + if (fsym == NULL || nodesc_arg || gfc_has_vector_subscript (e)) + return true; + + if (gfc_is_span_addressed_dummy (fsym)) + return false; + + return !(fsym->attr.pointer && !fsym->attr.contiguous && fsym->as + && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_DEFERRED)); +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -7985,14 +8027,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else if (e->expr_type == EXPR_VARIABLE && is_subref_array (e) - && !(fsym && fsym->attr.pointer)) + && !(fsym && fsym->attr.pointer) + && copy_in_out_allowed (fsym, e, nodesc_arg)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then - written back after the procedure call. */ + written back after the procedure call. The elements of + a span addressed dummy passed on as a whole are usually + contiguous, so the copy is made conditional. */ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, - fsym && fsym->attr.pointer); + fsym && fsym->attr.pointer, fsym, sym->name, + NULL, + gfc_is_span_addressed_dummy (e->symtree->n.sym) + && !is_subobject_ref (e)); else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE @@ -8004,20 +8052,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.expr = e->symtree->n.sym->backend_decl; else if (gfc_is_class_array_ref (e, NULL) - && fsym && fsym->ts.type == BT_DERIVED) + && fsym && fsym->ts.type == BT_DERIVED + && copy_in_out_allowed (fsym, e, nodesc_arg)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then - written back after the procedure call. - OOP-TODO: Insert code so that if the dynamic type is - the same as the declared type, copy-in/copy-out does - not occur. */ + written back after the procedure call. */ gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym->attr.intent, fsym->attr.pointer); else if (gfc_is_class_array_function (e) - && fsym && fsym->ts.type == BT_DERIVED) + && fsym && fsym->ts.type == BT_DERIVED + && copy_in_out_allowed (fsym, e, nodesc_arg)) /* See previous comment. For function actual argument, the write out is not needed so the intent is set as intent in. */ @@ -8038,10 +8085,17 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym->attr.pointer); } else - /* This is where we introduce a temporary to store the - result of a non-lvalue array expression. */ - gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, - sym->name, NULL); + { + /* Having declined copy-in/copy-out above, a subobject of an + array is described by a spanned descriptor. */ + if (e->expr_type == EXPR_VARIABLE && is_subref_array (e)) + parmse.force_no_tmp = 1; + + /* This is where we introduce a temporary to store the + result of a non-lvalue array expression. */ + gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, + sym->name, NULL); + } /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 31d81e517e72..06c96d5a0a9e 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2386,9 +2386,10 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) se->expr = cond; } - /* A pointer that does not have the CONTIGUOUS attribute needs to be checked - if it points to an array whose span differs from the element size. */ - if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous) + /* An array that is addressed by the span of its descriptor needs to be + checked if that span differs from the element size. */ + if (as && sym && !sym->attr.contiguous + && (IS_POINTER (sym) || gfc_is_span_addressed_dummy (sym))) { tree span = gfc_conv_descriptor_span_get (desc); tmp = fold_convert (TREE_TYPE (span), diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index cf37261673cf..c2ad65c9a747 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -389,6 +389,27 @@ gfc_build_addr_expr (tree type, tree t) } +/* Return the descriptor that carries the span of DECL, which is marked as a + pointer array. Such a decl usually is a descriptor. The local decl of a + descriptorless dummy array is not, so its span comes from the descriptor it + was built from, which is the saved one. */ + +tree +gfc_get_span_descriptor (tree decl) +{ + if (DECL_P (decl) + && GFC_ARRAY_TYPE_P (TREE_TYPE (decl)) + && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + return decl; +} + + static tree get_array_span (tree type, tree decl) { @@ -409,7 +430,9 @@ get_array_span (tree type, tree decl) && (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE) && TYPE_STRING_FLAG (type)) { - if (TREE_CODE (decl) == PARM_DECL) + if (DECL_P (decl) && GFC_DECL_PTR_ARRAY_P (decl)) + decl = gfc_get_span_descriptor (decl); + else if (TREE_CODE (decl) == PARM_DECL) decl = build_fold_indirect_ref_loc (input_location, decl); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) span = gfc_conv_descriptor_span_get (decl); @@ -449,11 +472,7 @@ get_array_span (tree type, tree decl) span = gfc_resize_class_size_with_len (NULL, decl, span); } else if (GFC_DECL_PTR_ARRAY_P (decl)) - { - if (TREE_CODE (decl) == PARM_DECL) - decl = build_fold_indirect_ref_loc (input_location, decl); - span = gfc_conv_descriptor_span_get (decl); - } + span = gfc_conv_descriptor_span_get (gfc_get_span_descriptor (decl)); else span = NULL_TREE; } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0bdee5820fdd..408acf081f11 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -641,6 +641,9 @@ tree gfc_build_array_ref (tree, tree, tree, /* Build an array ref using pointer arithmetic. */ tree gfc_build_spanned_array_ref (tree base, tree offset, tree span); +/* Return the descriptor holding the span of a pointer array decl. */ +tree gfc_get_span_descriptor (tree); + /* Creates a label. Decl is artificial if label_id == NULL_TREE. */ tree gfc_build_label_decl (tree); diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 index 7b1149aaa459..91547e8e3379 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 @@ -17,7 +17,9 @@ end ! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } } ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+;" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(D.\[0-9\]+ \\* 16\\);" 1 "original" } } +! A TARGET assumed-shape dummy is addressed with the descriptor's runtime +! span, so the element offset is span-scaled instead of a constant 16. +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(\\(yyy->span \\* D.\[0-9\]+\\) \\* 4\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/class_to_type_5.f90 b/gcc/testsuite/gfortran.dg/class_to_type_5.f90 new file mode 100644 index 000000000000..ad299db514d5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_5.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR 53800 + +! Check that a CLASS array with an extended dynamic type passed to an +! assumed-shape TYPE dummy aliases the original storage, rather +! than a copy-in/copy-out temporary that goes stale after return. +! +! Reported by Tobias Burnus <[email protected]> + +program class_to_type + implicit none + type t + integer :: i + end type t + type, extends(t) :: t2 + integer :: j + end type t2 + class(t), target, allocatable :: a(:,:) + type(t), pointer :: ptr + + allocate (t2 :: a(5,5)) + a(:,:)%i = 53 + a(3,3)%i = 42 + a(4,4)%i = 74 + + call f (a) + if (ptr%i /= 42) stop 1 + a(3,3)%i = 999 + if (ptr%i /= 999) stop 2 +contains + subroutine f(x) + type(t), target :: x(:,:) + ptr => x(3,3) + end subroutine f +end program class_to_type diff --git a/gcc/testsuite/gfortran.dg/class_to_type_6.f90 b/gcc/testsuite/gfortran.dg/class_to_type_6.f90 new file mode 100644 index 000000000000..67d02c67fb87 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_6.f90 @@ -0,0 +1,93 @@ +! { dg-do run } +! PR53800 + +! A CLASS array actual passed to an assumed-shape TYPE dummy only +! aliases the actual's storage when the dummy has the TARGET attribute. +! +module m + implicit none + type :: t + integer :: i + end type + type, extends(t) :: t2 + integer :: pad(4) + end type + type :: u + integer :: k + end type + type :: c + integer :: i + type(u) :: sub(3) + end type + type, extends(c) :: c2 + integer :: pad(4) + end type +contains + ! A dummy (non-target): copy-in/copy-out, + subroutine plain (x) + type(t) :: x(:) + if (any (x%i /= [1,2,3,4,5])) stop 1 + call expl (x) + if (any (cshift (x%i, 1) /= [2,3,4,5,1])) stop 3 + if (any (pack (x%i, [.true.,.false.,.true.,.false.,.true.]) & + /= [1,3,5])) stop 4 + if (any (reshape (x%i, [1,5]) /= reshape ([1,2,3,4,5], [1,5]))) stop 5 + call to_class (x) + end subroutine + + subroutine expl (y) + type(t) :: y(5) + if (any (y%i /= [1,2,3,4,5])) stop 2 + end subroutine + + subroutine to_class (z) + class(t) :: z(:) + if (any (z%i /= [1,2,3,4,5])) stop 6 + end subroutine + + ! A component sub-array of a span-carrying dummy has its own element + ! size and must not inherit the parent's span. + subroutine comp (x) + type(c), target :: x(:) + call inner (x(2)%sub) + end subroutine + + subroutine inner (s) + type(u) :: s(:) + if (any (s%k /= [21,22,23])) stop 7 + end subroutine +end module + +program class_to_type_6 + use m + implicit none + class(t), target, allocatable :: a(:) + class(c), target, allocatable :: b(:) + type(t), pointer :: p + integer :: n + + allocate (t2 :: a(5)) + do n = 1, 5 + a(n)%i = n + end do + call plain (a) + + allocate (c2 :: b(3)) + do n = 1, 3 + b(n)%i = 10 * n + b(n)%sub(:)%k = [10*n+1, 10*n+2, 10*n+3] + end do + call comp (b) + + ! A TARGET assumed-shape dummy without CONTIGUOUS does alias. + call aliased (a) + if (p%i /= 3) stop 8 + a(3)%i = 999 + if (p%i /= 999) stop 9 + +contains + subroutine aliased (x) + type(t), target :: x(:) + p => x(3) + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/class_to_type_7.f90 b/gcc/testsuite/gfortran.dg/class_to_type_7.f90 new file mode 100644 index 000000000000..c5f74809c466 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_7.f90 @@ -0,0 +1,151 @@ +! { dg-do run } +! PR fortran/53800 + +! Further cases in which a dummy must be associated with the actual +! argument's storage rather than a copy-in/copy-out temporary: an +! intrinsic-type component of a CLASS array, a POINTER dummy and an +! assumed-rank TARGET dummy. +! +! Variations contributed by Mikael Morin <[email protected]> + +module m + implicit none + type t + integer :: i + end type t + type, extends(t) :: t2 + integer :: j + end type t2 +end module m + +! An intrinsic-type component of a CLASS array to an INTEGER TARGET dummy. +subroutine test_integer_component () + use m + implicit none + class(t), target, allocatable :: a(:,:) + integer, pointer :: ptr + + allocate (t2 :: a(5,5)) + a(:,:)%i = 53 + a(3,3)%i = 42 + + call f (a%i) + if (ptr /= 42) stop 1 + a(3,3)%i = 999 + if (ptr /= 999) stop 2 +contains + subroutine f(x) + integer, target :: x(:,:) + ptr => x(3,3) + end subroutine f +end subroutine test_integer_component + +! A component of a plain derived-type array to an INTEGER TARGET dummy. +subroutine test_subref_component () + implicit none + type u + integer :: i + integer :: pad + end type u + type(u), target :: a(5,5) + integer, pointer :: ptr + + a(:,:)%i = 53 + a(3,3)%i = 42 + + call f (a%i) + if (ptr /= 42) stop 3 + a(3,3)%i = 999 + if (ptr /= 999) stop 4 +contains + subroutine f(x) + integer, target :: x(:,:) + ptr => x(3,3) + end subroutine f +end subroutine test_subref_component + +! A character component of a derived-type array to a CHARACTER TARGET dummy. +subroutine test_character_component () + implicit none + type u + character(len=4) :: c + integer :: pad + end type u + type(u), target :: a(6) + character(len=4), pointer :: ptr + integer :: k + + do k = 1, 6 + a(k)%c = "ab00" + end do + a(4)%c = "zzzz" + + call f (a%c) + if (ptr /= "zzzz") stop 10 + a(4)%c = "qqqq" + if (ptr /= "qqqq") stop 11 +contains + subroutine f(x) + character(len=4), target :: x(:) + ptr => x(4) + end subroutine f +end subroutine test_character_component + +! A CLASS POINTER array to a TYPE POINTER dummy. +subroutine test_pointer_dummy () + use m + implicit none + class(t), pointer :: a(:,:) + type(t), pointer :: ptr + + allocate (t2 :: a(5,5)) + a(:,:)%i = 53 + a(3,3)%i = 42 + + call f (a) + if (ptr%i /= 42) stop 5 + a(3,3)%i = 999 + if (ptr%i /= 999) stop 6 + deallocate (a) +contains + subroutine f(x) + type(t), pointer :: x(:,:) + ptr => x(3,3) + end subroutine f +end subroutine test_pointer_dummy + +! A CLASS array to an assumed-rank TARGET dummy, selected with SELECT RANK. +subroutine test_assumed_rank () + use m + implicit none + class(t), target, allocatable :: a(:,:) + type(t), pointer :: ptr + + allocate (t2 :: a(5,5)) + a(:,:)%i = 53 + a(3,3)%i = 42 + + call f (a) + if (ptr%i /= 42) stop 7 + a(3,3)%i = 999 + if (ptr%i /= 999) stop 8 +contains + subroutine f(x) + type(t), target :: x(..) + select rank (x) + rank (2) + ptr => x(3,3) + rank default + error stop 9 + end select + end subroutine f +end subroutine test_assumed_rank + +program class_to_type_7 + implicit none + call test_integer_component () + call test_subref_component () + call test_character_component () + call test_pointer_dummy () + call test_assumed_rank () +end program class_to_type_7 diff --git a/gcc/testsuite/gfortran.dg/class_to_type_8.f90 b/gcc/testsuite/gfortran.dg/class_to_type_8.f90 new file mode 100644 index 000000000000..48851d42cd1b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_8.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR fortran/53800 + +! A component of an array of extended derived types, passed to a TARGET +! dummy, is addressed through the span of its descriptor. This must also +! hold for a section of such a dummy and for a subobject reference applied +! to it. +! +! Contributed by Mikael Morin <[email protected]> + +program p + implicit none + type :: t + integer :: c1, c2 + end type + type, extends(t) :: u + integer :: c3 + end type + type, extends(u) :: v + integer :: c4 + end type + type(v), target :: x(12) + integer :: i + x = [(v(i,i*i,i,i), i=1,size(x))] + call s1(x(2::3)%c2, 1) + call s2(x%u) +contains + subroutine s1(a, error_idx) + integer, intent(in) :: error_idx + integer, target :: a(:) + if (any(a /= [4, 25, 64, 121])) error stop error_idx * 10 + 1 + end subroutine + subroutine s2(a) + type(u), target :: a(:) + if (any(a%c2 /= [(i*i, i=1,12)])) error stop 2 + if (any(a(2::3)%c2 /= [4, 25, 64, 121])) error stop 3 + call s1(a(2::3)%c2, 2) + call s3(a(2::3)%c2) + if (any(x(2::3)%c2 /= [-4, -25, -64, -121])) error stop 5 + x = [(v(i,i*i,i,i), i=1,size(x))] + end subroutine + subroutine s3(a) + integer :: a(:) ! copy-in/copy-out + if (any(a /= [4, 25, 64, 121])) error stop 4 + a = -a + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/class_to_type_9.f90 b/gcc/testsuite/gfortran.dg/class_to_type_9.f90 new file mode 100644 index 000000000000..40f4e6a53de4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_to_type_9.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! PR fortran/53800 + +! A TARGET dummy associated with elements that are spaced by more than the +! element size: pointers to it stay valid after the call, it is written +! through, it is not contiguous, it is copied when passed on to a dummy +! without the TARGET attribute and it is transferred element by element. + +module m + implicit none + type :: t + integer :: c1, c2 + end type + integer, pointer :: saved(:) => null() +contains + subroutine chk(a, opt) + integer, target :: a(:) + integer, optional, target :: opt(:) + character(24) :: line + if (is_contiguous(a)) stop 1 + if (present(opt)) stop 2 + write (line, '(4I3)') a + if (line(1:12) /= ' 1 4 9 16') stop 3 + if (sum(a) /= 30) stop 4 + call packed(a) + call assumed_size(a) + saved => a + a(2) = -a(2) + end subroutine + subroutine packed(b) ! copy-in/copy-out + integer :: b(:) + if (any(b /= [1, 4, 9, 16])) stop 5 + if (.not. is_contiguous(b)) stop 6 + end subroutine + subroutine assumed_size(c) ! no descriptor + integer :: c(*) + if (any(c(1:4) /= [1, 4, 9, 16])) stop 7 + end subroutine + subroutine rank_any(d) + integer, target :: d(..) + select rank (d) + rank (1) + if (any(d /= [1, 2, 3, 4])) stop 8 + saved => d + rank default + stop 9 + end select + end subroutine +end module + +program p + use m + implicit none + type(t), target :: x(4) + integer :: i + x = [(t(i, i*i), i=1,4)] + + call chk(x%c2) + if (any(x%c2 /= [1, -4, 9, 16])) stop 10 + saved = 0 + if (any(x%c2 /= [0, 0, 0, 0])) stop 11 + if (any(x%c1 /= [1, 2, 3, 4])) stop 12 + + call rank_any(x%c1) + saved = 7 + if (any(x%c1 /= [7, 7, 7, 7])) stop 13 +end program diff --git a/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90 b/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90 index c3453a579aea..ae5104beb486 100644 --- a/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90 +++ b/libgomp/testsuite/libgomp.oacc-fortran/host_data-5.F90 @@ -74,10 +74,17 @@ subroutine foo (p2, parr, host_p, host_parr, cond) ! { dg-note {variable 'host_p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-5 } ! { dg-note {variable 'host_parr\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-6 } ! { dg-note {variable 'C\.[0-9]+' declared in block potentially has improper OpenACC privatization level: 'const_decl'} "TODO" { target *-*-* } .-7 } - ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-8 } - ! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-9 } - ! { dg-note {variable 'transfer\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-10 } - ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-11 } + ! { dg-note {variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-8 } + ! { dg-note {variable 'transfer\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: artificial} "" { target *-*-* } .-9 } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-10 } + ! The TARGET dummy 'parr' is addressed by the span of its descriptor, so + ! passing it to a dummy without a descriptor packs it when it is not + ! contiguous. + ! { dg-note {variable 'iftmp\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-14 } + ! { dg-note {variable 'atmp\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-15 } + ! { dg-note {variable 'arg_ptr\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-16 } + ! { dg-note {variable 'contiguous\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-17 } + ! { dg-note {variable 'S\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-18 } if (.not. acc_is_present(p, c_sizeof(p))) stop 11 if (.not. acc_is_present(parr, 1)) stop 12 ! Not inside a host_data construct, so still the host pointer.