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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 12973c6bc8560ed70fe234299a2589733c59e4dd..5db327cd12b7df4d0092747e10314f0edda72ead 100644 (file)
--- 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 c11abb07eb6e89c15c49a676e48c6967e152d973..8801a15c3a8d54bd4d154834a6e8ec53564f762b 100644 (file)
--- 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 8e1a2b04ed43df25760ed4b79b61f53ed2ac21a4..fd2da4638252f97b17de3d179b2469c2be1e882d 100644 (file)
--- 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 5a72438e86223cf318d935f9f0ab0a92ab1b9cb3..56160e29d9f4405a3e66fee2cd8b3d56b26bebbe 100644 (file)
--- 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 79f7822041dc3c19ae13fb714c647020505704d0..41da970e830862c50c216ca35dd742b1360a885e 100644 (file)
--- 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