https://gcc.gnu.org/g:35f56012806432fd89bbae431950a8dc5f6729a3
commit r15-3035-g35f56012806432fd89bbae431950a8dc5f6729a3
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Wed Jul 17 12:30:52 2024 +0200
Fortran: Fix [Coarray] ICE in conv_caf_send, at
fortran/trans-intrinsic.c:1950 [PR84246]
Fix ICE caused by converted expression already being pointer by checking
for its type. Lift rewrite to caf_send completely into resolve and
prevent more temporary arrays.
PR fortran/84246
gcc/fortran/ChangeLog:
* resolve.cc (caf_possible_reallocate): Detect arrays that may
be reallocated by caf_send.
(resolve_ordinary_assign): More reliably detect assignments
where a rewrite to caf_send is needed.
* trans-expr.cc (gfc_trans_assignment_1): Remove rewrite to
caf_send, because this is done by resolve now.
* trans-intrinsic.cc (conv_caf_send): Prevent unneeded temporary
arrays.
libgfortran/ChangeLog:
* caf/single.c (send_by_ref): Created array's lbound is now 1
and the offset set correctly.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray_allocate_7.f08: Adapt to array being
allocate by caf_send.
Diff:
---
gcc/fortran/resolve.cc | 18 ++++++++++++++++++
gcc/fortran/trans-expr.cc | 23 -----------------------
gcc/fortran/trans-intrinsic.cc | 17 ++++++++++-------
gcc/testsuite/gfortran.dg/coarray_allocate_7.f08 | 4 +---
libgfortran/caf/single.c | 6 +++---
5 files changed, 32 insertions(+), 36 deletions(-)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 12973c6bc85..5db327cd12b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11601,6 +11601,23 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
}
}
+bool
+caf_possible_reallocate (gfc_expr *e)
+{
+ symbol_attribute caf_attr;
+ gfc_ref *last_arr_ref = nullptr;
+
+ caf_attr = gfc_caf_attr (e);
+ if (!caf_attr.codimension || !caf_attr.allocatable || !caf_attr.dimension)
+ return false;
+
+ /* Only full array refs can indicate a needed reallocation. */
+ for (gfc_ref *ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.dimen)
+ last_arr_ref = ref;
+
+ return last_arr_ref && last_arr_ref->u.ar.type == AR_FULL;
+}
/* Does everything to resolve an ordinary assignment. Returns true
if this is an interface assignment. */
@@ -11845,6 +11862,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace
*ns)
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
&& (lhs_coindexed
+ || caf_possible_reallocate (lhs)
|| (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c11abb07eb6..8801a15c3a8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12701,29 +12701,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
expr1->must_finalize = 0;
}
- else if (flag_coarray == GFC_FCOARRAY_LIB
- && lhs_caf_attr.codimension && rhs_caf_attr.codimension
- && ((lhs_caf_attr.allocatable && lhs_refs_comp)
- || (rhs_caf_attr.allocatable && rhs_refs_comp)))
- {
- /* Only detour to caf_send[get][_by_ref] () when the lhs or rhs is an
- allocatable component, because those need to be accessed via the
- caf-runtime. No need to check for coindexes here, because resolve
- has rewritten those already. */
- gfc_code code;
- gfc_actual_arglist a1, a2;
- /* Clear the structures to prevent accessing garbage. */
- memset (&code, '\0', sizeof (gfc_code));
- memset (&a1, '\0', sizeof (gfc_actual_arglist));
- memset (&a2, '\0', sizeof (gfc_actual_arglist));
- a1.expr = expr1;
- a1.next = &a2;
- a2.expr = expr2;
- a2.next = NULL;
- code.ext.actual = &a1;
- code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
- tmp = gfc_conv_intrinsic_subroutine (&code);
- }
else if (!is_poly_assign && expr2->must_finalize
&& expr1->ts.type == BT_CLASS
&& expr2->ts.type == BT_CLASS)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 8e1a2b04ed4..fd2da463825 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -1945,11 +1945,14 @@ conv_caf_send (gfc_code *code) {
tree lhs_type = NULL_TREE;
tree vec = null_pointer_node, rhs_vec = null_pointer_node;
symbol_attribute lhs_caf_attr, rhs_caf_attr;
+ bool lhs_is_coindexed, rhs_is_coindexed;
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
lhs_expr = code->ext.actual->expr;
rhs_expr = code->ext.actual->next->expr;
+ lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
+ rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
? boolean_false_node : boolean_true_node;
gfc_init_block (&block);
@@ -1966,7 +1969,8 @@ conv_caf_send (gfc_code *code) {
if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
{
lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
- lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+ if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)))
+ lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
}
else
{
@@ -1999,7 +2003,7 @@ conv_caf_send (gfc_code *code) {
{
bool has_vector = gfc_has_vector_subscript (lhs_expr);
- if (gfc_is_coindexed (lhs_expr) || !has_vector)
+ if (lhs_is_coindexed || !has_vector)
{
/* If has_vector, pass descriptor for whole array and the
vector bounds separately. */
@@ -2030,7 +2034,7 @@ conv_caf_send (gfc_code *code) {
*ar = ar2;
}
}
- else
+ else if (rhs_is_coindexed)
{
/* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
indexed array expression. This is rewritten to:
@@ -2122,13 +2126,12 @@ conv_caf_send (gfc_code *code) {
/* Special case: RHS is a coarray but LHS is not; this code path avoids a
temporary and a loop. */
- if (!gfc_is_coindexed (lhs_expr)
+ if (!lhs_is_coindexed && rhs_is_coindexed
&& (!lhs_caf_attr.codimension
|| !(lhs_expr->rank > 0
&& (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
{
bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
- gcc_assert (gfc_is_coindexed (rhs_expr));
gfc_init_se (&rhs_se, NULL);
if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
{
@@ -2217,7 +2220,7 @@ conv_caf_send (gfc_code *code) {
bool has_vector = false;
tree tmp2;
- if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
+ if (rhs_is_coindexed && gfc_has_vector_subscript (rhs_expr))
{
has_vector = true;
ar = gfc_find_array_ref (rhs_expr);
@@ -2271,7 +2274,7 @@ conv_caf_send (gfc_code *code) {
gfc_add_block_to_block (&block, &team_se.post);
}
- if (!gfc_is_coindexed (rhs_expr))
+ if (!rhs_is_coindexed)
{
if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
{
diff --git a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08
b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08
index 5a72438e862..56160e29d9f 100644
--- a/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08
+++ b/gcc/testsuite/gfortran.dg/coarray_allocate_7.f08
@@ -23,7 +23,5 @@ program main
if ( object%indices(1) /= 1 ) STOP 2
end program
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1,
&\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\)
\\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 8,
&\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\)
\\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct
mytype\\) \\*object\\).indices.token, 1, 0B, 0B, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(0, 7, \\(void
\\*\\) &mytype\\.\[0-9\]+\\.indices\\.token, &mytype\\.\[0-9\]+\\.indices, 0B,
0B, 0\\);" 1 "original" } }
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 79f7822041d..41da970e830 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -2131,14 +2131,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t
*src_index,
/* Assume that the rank and the dimensions fit for copying src
to dst. */
GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
- dst->offset = 0;
stride_dst = 1;
for (size_t d = 0; d < src_rank; ++d)
{
extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
- GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
- GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
+ GFC_DIMENSION_LBOUND (dst->dim[d]) = 1;
+ GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst;
GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
+ dst->offset = -extent_dst;
stride_dst *= extent_dst;
}
/* Null the data-pointer to make register_component allocate
