From 35f56012806432fd89bbae431950a8dc5f6729a3 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Wed, 17 Jul 2024 12:30:52 +0200 Subject: [PATCH] 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. --- gcc/fortran/resolve.cc | 18 +++++++++++++++ gcc/fortran/trans-expr.cc | 23 ------------------- gcc/fortran/trans-intrinsic.cc | 17 ++++++++------ .../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