Re: [Ping x 3, Fortran, Patch, coarray, PR84246, v2] Fix for [Coarray] ICE in conv_caf_send, at fortran/trans-intrinsic.c:1950

[Andre Vehreschild <vehre@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 878 bytes --]

Hi all,

another ping on this patch.

Regtests ok on x86_64-pc-linux-gnu on updated master. Ok for mainline?

Regards,
	Andre

On Fri, 9 Aug 2024 16:29:08 +0200
Andre Vehreschild <vehre@gmx.de> wrote:

> Ping!
>
> On Wed, 17 Jul 2024 15:15:51 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
>
> > Hi all,
> >
> > attached patch fixes an ICE in coarray code, where the coarray expression
> > already was a pointer, which confused the compiler. Furthermore have I
> > removed a rewrite to a caf_send late in the trans-phase. This is now done
> > in the resolve stage to have only a single place for these rewriting
> > actions.
> >
> > Regtests ok on x86_64-pc-linux-gnu / Fedora 39. Ok for mainline?
> >
> > Regards,
> > 	Andre
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
>
>


--
Andre Vehreschild * Email: vehre ad gmx dot de

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr84246_3.patch --]
[-- Type: text/x-patch, Size: 9447 bytes --]

From dadd7507001208777d8d10d3653f8678d6c91b53 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
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
--
2.46.0