[PATCH] Fortran: checking and simplification of RESHAPE intrinsic [PR103794]

[Harald Anlauf <anlauf@gmx.de>]

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

Dear all,

checking and simplification of the RESHAPE intrinsic could fail in
various ways for sufficiently complicated arguments, like array
constructors.  Debugging revealed that in these cases we determined
that the array arguments were constant but we did not properly
simplify and expand the constructors.

A possible solution is the extend the test for constant arrays -
which already does an expansion for initialization expressions -
to also perform an expansion for small constructors in the
non-initialization case.

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

Thanks,
Harald


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

From bfb708fdb6c313473a3054be710c630dcdebf69d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sun, 21 May 2023 22:25:29 +0200
Subject: [PATCH] Fortran: checking and simplification of RESHAPE intrinsic
 [PR103794]

gcc/fortran/ChangeLog:

	PR fortran/103794
	* check.cc (gfc_check_reshape): Expand constant arguments SHAPE and
	ORDER before checking.
	* gfortran.h (gfc_is_constant_array_expr): Add prototype.
	* iresolve.cc (gfc_resolve_reshape): Expand constant argument SHAPE.
	* simplify.cc (is_constant_array_expr): If array is determined to be
	constant, expand small array constructors if needed.
	(gfc_is_constant_array_expr): Wrapper for is_constant_array_expr.
	(gfc_simplify_reshape): Fix check for insufficient elements in SOURCE
	when no padding specified.

gcc/testsuite/ChangeLog:

	PR fortran/103794
	* gfortran.dg/reshape_10.f90: New test.
	* gfortran.dg/reshape_11.f90: New test.
---
 gcc/fortran/check.cc                     |  6 +++--
 gcc/fortran/gfortran.h                   |  1 +
 gcc/fortran/iresolve.cc                  |  2 +-
 gcc/fortran/simplify.cc                  | 25 ++++++++++++++---
 gcc/testsuite/gfortran.dg/reshape_10.f90 | 34 ++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/reshape_11.f90 | 15 +++++++++++
 6 files changed, 77 insertions(+), 6 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/reshape_10.f90
 create mode 100644 gcc/testsuite/gfortran.dg/reshape_11.f90

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 3dd1711aa14..4086dc71d34 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4723,7 +4723,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
     }

   gfc_simplify_expr (shape, 0);
-  shape_is_const = gfc_is_constant_expr (shape);
+  shape_is_const = gfc_is_constant_array_expr (shape);

   if (shape->expr_type == EXPR_ARRAY && shape_is_const)
     {
@@ -4732,6 +4732,8 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
       for (i = 0; i < shape_size; ++i)
 	{
 	  e = gfc_constructor_lookup_expr (shape->value.constructor, i);
+	  if (e == NULL)
+	    break;
 	  if (e->expr_type != EXPR_CONSTANT)
 	    continue;

@@ -4764,7 +4766,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
       if (!type_check (order, 3, BT_INTEGER))
 	return false;

-      if (order->expr_type == EXPR_ARRAY && gfc_is_constant_expr (order))
+      if (order->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (order))
 	{
 	  int i, order_size, dim, perm[GFC_MAX_DIMENSIONS];
 	  gfc_expr *e;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9dd6b45f112..8cfa8fd3afd 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3970,6 +3970,7 @@ bool gfc_fix_implicit_pure (gfc_namespace *);

 void gfc_convert_mpz_to_signed (mpz_t, int);
 gfc_expr *gfc_simplify_ieee_functions (gfc_expr *);
+bool gfc_is_constant_array_expr (gfc_expr *);
 bool gfc_is_size_zero_array (gfc_expr *);

 /* trans-array.cc  */
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 7880aba63bb..571e1bd3441 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -2424,7 +2424,7 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
       break;
     }

-  if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_expr (shape))
+  if (shape->expr_type == EXPR_ARRAY && gfc_is_constant_array_expr (shape))
     {
       gfc_constructor *c;
       f->shape = gfc_get_shape (f->rank);
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 6ba2040e61c..3f77203e62e 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -254,12 +254,19 @@ is_constant_array_expr (gfc_expr *e)
 	break;
       }

-  /* Check and expand the constructor.  */
-  if (!array_OK && gfc_init_expr_flag && e->rank == 1)
+  /* Check and expand the constructor.  We do this when either
+     gfc_init_expr_flag is set or for not too large array constructors.  */
+  bool expand;
+  expand = (e->rank == 1
+	    && e->shape
+	    && (mpz_cmp_ui (e->shape[0], flag_max_array_constructor) < 0));
+
+  if (!array_OK && (gfc_init_expr_flag || expand) && e->rank == 1)
     {
+      bool saved_init_expr_flag = gfc_init_expr_flag;
       array_OK = gfc_reduce_init_expr (e);
       /* gfc_reduce_init_expr resets the flag.  */
-      gfc_init_expr_flag = true;
+      gfc_init_expr_flag = saved_init_expr_flag;
     }
   else
     return array_OK;
@@ -284,6 +291,13 @@ is_constant_array_expr (gfc_expr *e)
   return array_OK;
 }

+bool
+gfc_is_constant_array_expr (gfc_expr *e)
+{
+  return is_constant_array_expr (e);
+}
+
+
 /* Test for a size zero array.  */
 bool
 gfc_is_size_zero_array (gfc_expr *array)
@@ -7001,6 +7015,11 @@ gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
 	  if (npad <= 0)
 	    {
 	      mpz_clear (index);
+	      if (pad == NULL)
+		gfc_error ("Without padding, there are not enough elements "
+			   "in the intrinsic RESHAPE source at %L to match "
+			   "the shape", &source->where);
+	      gfc_free_expr (result);
 	      return NULL;
 	    }
 	  j = j - nsource;
diff --git a/gcc/testsuite/gfortran.dg/reshape_10.f90 b/gcc/testsuite/gfortran.dg/reshape_10.f90
new file mode 100644
index 00000000000..a148e0a2031
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reshape_10.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fmax-array-constructor=65536 -fdump-tree-original" }
+! PR fortran/103794
+
+program p
+  integer :: i, j
+  integer, parameter :: a(2) = 2
+  integer, parameter :: e(*) = [(reshape([1,2,3,4],  (a*i)), i=1,1)]
+  integer, parameter :: f(*,*) = reshape([1,2,3,4], [(a*i,   i=1,1)])
+  integer, parameter :: g(*,*) = reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)])
+  integer, parameter :: s1(*) = &
+       shape(reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]))
+  logical, parameter :: l1 = all (e == [1,2,3,4])
+  logical, parameter :: l2 = all (f == reshape([1,2,3,4],[2,2]))
+  logical, parameter :: l3 = size (s1) == 2 .and. all (s1 == 2)
+  logical, parameter :: l4 = all (f == g)
+  print *, e
+  print *, f
+  if (.not. l1) stop 1
+  if (.not. l2) stop 2
+  if (.not. l3) stop 3
+  if (.not. l4) stop 4
+  if (any (shape (reshape([1,2], [([2]*i, i=1,1)])) /= 2)) stop 5
+  ! The following is compile-time simplified due to shape():
+  print *, shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]))
+  if (any (shape(reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])) /= 2)) stop 6
+  if (any (reshape([([1,2,3,4],j=1,16383)],[(a*i,i=1,1)]) /= f)) stop 7
+  ! The following is not compile-time simplified:
+  print *, reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)])
+  if (any (reshape([([1,2,3,4],j=1,20000)],[(a*i,i=1,1)]) /= f)) stop 8
+end
+
+! { dg-final { scan-tree-dump-times "_gfortran_reshape_4" 2 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_stop_numeric" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/reshape_11.f90 b/gcc/testsuite/gfortran.dg/reshape_11.f90
new file mode 100644
index 00000000000..17c14061494
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/reshape_11.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fmax-array-constructor=65536" }
+! PR fortran/103794
+
+program p
+  integer :: i, j
+  integer, parameter :: a(2) = 2, m = 20000
+  integer, parameter :: e(*) = &
+       [(reshape([1,2,3],  (a*i)), i=1,1)]     ! { dg-error "not enough elements" }
+  integer, parameter :: g(*,*) = &
+           reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)]) ! { dg-error "number of elements" }
+  print *, reshape([([1,2,3,4],j=1,m)],[(a*i,i=1,1)])
+  print *,   reshape([1,2,3], [(a*i,  i=1,1)]) ! { dg-error "not enough elements" }
+  print *, [(reshape([1,2,3],  (a*i)),i=1,1)]  ! { dg-error "not enough elements" }
+end
--
2.35.3