(Partial) Implementation of simplificaiton of CSHIFT
diff mbox

Message ID 20151120200947.GA61350@troutmask.apl.washington.edu
State New
Headers show

Commit Message

Steve Kargl Nov. 20, 2015, 8:09 p.m. UTC
On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote:
> 
> 2015-11-19  Steven G. Kargl  <kargl@gcc.gnu.org>
> 
> 	* intrinsic.h: Prototype for gfc_simplify_cshift
> 	* intrinsic.c (add_functions): Use gfc_simplify_cshift.
> 	* simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT.
> 	(gfc_simplify_spread): Remove a FIXME and add error condition.
>  
> 2015-11-19  Steven G. Kargl  <kargl@gcc.gnu.org>
> 
> 	* gfortran.dg/simplify_cshift_1.f90: New test.
> 

I've attached an updated patch.  The changes consists of
1) better/more comments
2) re-organize code to reduce copying of the array.
3) add optimization for a left/right shift that 
   returns the original array.
4) Don't leak memory.

Comments

Paul Richard Thomas Nov. 21, 2015, 10:41 a.m. UTC | #1
Hi Steve,

Just a couple of small typos:
"Unexpected expr_type cause an ICE" ;  causes?
"! An array of derived types workd too." ; works?

Apart from that it's OK for trunk.

Thanks for the patch

Cheers

Paul


On 20 November 2015 at 21:09, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote:
>>
>> 2015-11-19  Steven G. Kargl  <kargl@gcc.gnu.org>
>>
>>       * intrinsic.h: Prototype for gfc_simplify_cshift
>>       * intrinsic.c (add_functions): Use gfc_simplify_cshift.
>>       * simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT.
>>       (gfc_simplify_spread): Remove a FIXME and add error condition.
>>
>> 2015-11-19  Steven G. Kargl  <kargl@gcc.gnu.org>
>>
>>       * gfortran.dg/simplify_cshift_1.f90: New test.
>>
>
> I've attached an updated patch.  The changes consists of
> 1) better/more comments
> 2) re-organize code to reduce copying of the array.
> 3) add optimization for a left/right shift that
>    returns the original array.
> 4) Don't leak memory.
>
> --
> Steve
Steve Kargl Nov. 21, 2015, 4:26 p.m. UTC | #2
On Sat, Nov 21, 2015 at 11:41:51AM +0100, Paul Richard Thomas wrote:
> 
> Just a couple of small typos:
> "Unexpected expr_type cause an ICE" ;  causes?
> "! An array of derived types workd too." ; works?
> 
> Apart from that it's OK for trunk.
> 
> Thanks for the patch
> 

Thanks for the the review.  I don't have a clue as
to how to do simplification for rank > 2. :(
H.J. Lu Nov. 21, 2015, 6:07 p.m. UTC | #3
On Sat, Nov 21, 2015 at 8:26 AM, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Sat, Nov 21, 2015 at 11:41:51AM +0100, Paul Richard Thomas wrote:
>>
>> Just a couple of small typos:
>> "Unexpected expr_type cause an ICE" ;  causes?
>> "! An array of derived types workd too." ; works?
>>
>> Apart from that it's OK for trunk.
>>
>> Thanks for the patch
>>
>
> Thanks for the the review.  I don't have a clue as
> to how to do simplification for rank > 2. :(
>

It breaks bootstrap:

  int dm;

  /* DIM is only useful for rank > 1, but deal with it here as one can
     set DIM = 1 for rank = 1.  */
  if (dim)
    {
      if (!gfc_is_constant_expr (dim))
return NULL;
      dm = mpz_get_si (dim->value.integer);
    }
  else
    dm = 1;

dm is set, but never used.

H.J.
Steve Kargl Nov. 21, 2015, 6:20 p.m. UTC | #4
On Sat, Nov 21, 2015 at 10:07:35AM -0800, H.J. Lu wrote:
> On Sat, Nov 21, 2015 at 8:26 AM, Steve Kargl
> <sgk@troutmask.apl.washington.edu> wrote:
> > On Sat, Nov 21, 2015 at 11:41:51AM +0100, Paul Richard Thomas wrote:
> >>
> >> Just a couple of small typos:
> >> "Unexpected expr_type cause an ICE" ;  causes?
> >> "! An array of derived types workd too." ; works?
> >>
> >> Apart from that it's OK for trunk.
> >>
> >> Thanks for the patch
> >>
> >
> > Thanks for the the review.  I don't have a clue as
> > to how to do simplification for rank > 2. :(
> >
> 
> It breaks bootstrap:
> 
>   int dm;
> 
>   /* DIM is only useful for rank > 1, but deal with it here as one can
>      set DIM = 1 for rank = 1.  */
>   if (dim)
>     {
>       if (!gfc_is_constant_expr (dim))
> return NULL;
>       dm = mpz_get_si (dim->value.integer);
>     }
>   else
>     dm = 1;
> 
> dm is set, but never used.
> 

Perhaps, bootstrap needs to set appropriate warning levels.
H.J. Lu Nov. 21, 2015, 7:19 p.m. UTC | #5
On Sat, Nov 21, 2015 at 10:20 AM, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Sat, Nov 21, 2015 at 10:07:35AM -0800, H.J. Lu wrote:
>> On Sat, Nov 21, 2015 at 8:26 AM, Steve Kargl
>> <sgk@troutmask.apl.washington.edu> wrote:
>> > On Sat, Nov 21, 2015 at 11:41:51AM +0100, Paul Richard Thomas wrote:
>> >>
>> >> Just a couple of small typos:
>> >> "Unexpected expr_type cause an ICE" ;  causes?
>> >> "! An array of derived types workd too." ; works?
>> >>
>> >> Apart from that it's OK for trunk.
>> >>
>> >> Thanks for the patch
>> >>
>> >
>> > Thanks for the the review.  I don't have a clue as
>> > to how to do simplification for rank > 2. :(
>> >
>>
>> It breaks bootstrap:
>>
>>   int dm;
>>
>>   /* DIM is only useful for rank > 1, but deal with it here as one can
>>      set DIM = 1 for rank = 1.  */
>>   if (dim)
>>     {
>>       if (!gfc_is_constant_expr (dim))
>> return NULL;
>>       dm = mpz_get_si (dim->value.integer);
>>     }
>>   else
>>     dm = 1;
>>
>> dm is set, but never used.
>>
>
> Perhaps, bootstrap needs to set appropriate warning levels.

https://gcc.gnu.org/ml/gcc-regression/2015-11/msg00648.html
Steve Kargl Nov. 21, 2015, 7:26 p.m. UTC | #6
On Sat, Nov 21, 2015 at 11:19:22AM -0800, H.J. Lu wrote:
> On Sat, Nov 21, 2015 at 10:20 AM, Steve Kargl
> <sgk@troutmask.apl.washington.edu> wrote:
> > On Sat, Nov 21, 2015 at 10:07:35AM -0800, H.J. Lu wrote:
> >> On Sat, Nov 21, 2015 at 8:26 AM, Steve Kargl
> >> <sgk@troutmask.apl.washington.edu> wrote:
> >> > On Sat, Nov 21, 2015 at 11:41:51AM +0100, Paul Richard Thomas wrote:
> >> >>
> >> >> Just a couple of small typos:
> >> >> "Unexpected expr_type cause an ICE" ;  causes?
> >> >> "! An array of derived types workd too." ; works?
> >> >>
> >> >> Apart from that it's OK for trunk.
> >> >>
> >> >> Thanks for the patch
> >> >>
> >> >
> >> > Thanks for the the review.  I don't have a clue as
> >> > to how to do simplification for rank > 2. :(
> >> >
> >>
> >> It breaks bootstrap:
> >>
> >>   int dm;
> >>
> >>   /* DIM is only useful for rank > 1, but deal with it here as one can
> >>      set DIM = 1 for rank = 1.  */
> >>   if (dim)
> >>     {
> >>       if (!gfc_is_constant_expr (dim))
> >> return NULL;
> >>       dm = mpz_get_si (dim->value.integer);
> >>     }
> >>   else
> >>     dm = 1;
> >>
> >> dm is set, but never used.
> >>
> >
> > Perhaps, bootstrap needs to set appropriate warning levels.
> 
> https://gcc.gnu.org/ml/gcc-regression/2015-11/msg00648.html
> 

See 5 lines up.

Patch
diff mbox

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 230585)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -1659,9 +1659,11 @@  add_functions (void)
 
   make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
 
-  add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
-	     gfc_check_cshift, NULL, gfc_resolve_cshift,
-	     ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
+  add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+	     BT_REAL, dr, GFC_STD_F95,
+	     gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift,
+	     ar, BT_REAL, dr, REQUIRED,
+	     sh, BT_INTEGER, di, REQUIRED,
 	     dm, BT_INTEGER, ii, OPTIONAL);
 
   make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h	(revision 230585)
+++ gcc/fortran/intrinsic.h	(working copy)
@@ -271,6 +271,7 @@  gfc_expr *gfc_simplify_conjg (gfc_expr *
 gfc_expr *gfc_simplify_cos (gfc_expr *);
 gfc_expr *gfc_simplify_cosh (gfc_expr *);
 gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_dble (gfc_expr *);
 gfc_expr *gfc_simplify_digits (gfc_expr *);
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c	(revision 230585)
+++ gcc/fortran/simplify.c	(working copy)
@@ -1789,6 +1789,99 @@  gfc_simplify_count (gfc_expr *mask, gfc_
 
 
 gfc_expr *
+gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
+{
+  int dm;
+  gfc_expr *a;
+
+  /* DIM is only useful for rank > 1, but deal with it here as one can
+     set DIM = 1 for rank = 1.  */
+  if (dim)
+    {
+      if (!gfc_is_constant_expr (dim))
+	  return NULL;
+      dm = mpz_get_si (dim->value.integer);
+    }
+  else
+    dm = 1;
+
+  /* Copy array into 'a', simplify it, and then test for a constant array.
+     Unexpected expr_type cause an ICE.   */
+  switch (array->expr_type)
+    {
+      case EXPR_VARIABLE:
+      case EXPR_ARRAY:
+	a = gfc_copy_expr (array);
+	gfc_simplify_expr (a, 0);
+	if (!is_constant_array_expr (a))
+	  {
+	    gfc_free_expr (a);
+	    return NULL;
+	  }
+	break;
+      default:
+	gcc_unreachable ();
+    }
+
+  if (a->rank == 1)
+    {
+      gfc_constructor *ca, *cr;
+      gfc_expr *result;
+      mpz_t size;
+      int i, j, shft, sz;
+
+      if (!gfc_is_constant_expr (shift))
+	{
+	  gfc_free_expr (a);
+	  return NULL;
+	}
+
+      shft = mpz_get_si (shift->value.integer);
+
+      /*  Case (i):  If ARRAY has rank one, element i of the result is
+	  ARRAY (1 + MODULO (i + SHIFT ­ 1, SIZE (ARRAY))).  */
+
+      mpz_init (size);
+      gfc_array_size (a, &size);
+      sz = mpz_get_si (size);
+      mpz_clear (size);
+
+      /* Special case: rank 1 array with no shift or a complete shift to
+	 the original order!  */
+      if (shft == 0 || shft == sz || shft == 1 - sz)
+	return a;
+
+      /* Adjust shft to deal with right or left shifts. */
+      shft = shft < 0 ? 1 - shft : shft;
+
+      result = gfc_copy_expr (a);
+      cr = gfc_constructor_first (result->value.constructor);
+      for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr))
+	{
+	  j = (i + shft) % sz;
+	  ca = gfc_constructor_first (a->value.constructor);
+	  while (j-- > 0)
+	    ca = gfc_constructor_next (ca);
+	  cr->expr = gfc_copy_expr (ca->expr);
+	}
+
+      gfc_free_expr (a);
+      return result;
+    }
+  else
+    {
+      /* FIXME: Deal with rank > 1 arrays.  For now, don't leak memory
+	 and exit with an error message.  */
+      gfc_free_expr (a);
+      gfc_error ("Simplification of CSHIFT with an array with rank > 1 "
+	         "no yet support");
+    }
+
+  return NULL;
+}
+
+
+gfc_expr *
 gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
 {
   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
@@ -6089,10 +6182,11 @@  gfc_simplify_spread (gfc_expr *source, g
 	}
     }
   else
-    /* FIXME: Returning here avoids a regression in array_simplify_1.f90.
-       Replace NULL with gcc_unreachable() after implementing
-       gfc_simplify_cshift().  */
-    return NULL;
+    {
+      gfc_error ("Simplification of SPREAD at %L not yet implemented",
+		 &source->where);
+      return &gfc_bad_expr;
+    }
 
   if (source->ts.type == BT_CHARACTER)
     result->ts.u.cl = source->ts.u.cl;
Index: gcc/testsuite/gfortran.dg/simplify_cshift_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/simplify_cshift_1.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/simplify_cshift_1.f90	(working copy)
@@ -0,0 +1,46 @@ 
+! { dg-do run }
+program foo
+
+   implicit none
+   
+   type t
+      integer i
+   end type t
+
+   type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)]
+   type(t) e(5), q(5)
+
+   integer, parameter :: a(5) = [1, 2, 3, 4, 5]
+   integer i, b(5), c(5), v(5)
+
+   c = [1, 2, 3, 4, 5]
+
+   b = cshift(a, -2)
+   v = cshift(c, -2)
+   if (any(b /= v)) call abort
+
+   b = cshift(a, 2)
+   v = cshift(c, 2)
+   if (any(b /= v)) call abort
+
+   ! Special cases shift = 0, size(a), 1-size(a)
+   b = cshift([1, 2, 3, 4, 5], 0)
+   if (any(b /= a)) call abort
+   b = cshift([1, 2, 3, 4, 5], size(a))
+   if (any(b /= a)) call abort
+   b = cshift([1, 2, 3, 4, 5], 1-size(a))
+   if (any(b /= a)) call abort
+
+   ! simplification of array arg.
+   b = cshift(2 * a, 0)
+   if (any(b /= 2 * a)) call abort
+
+   ! An array of derived types workd too.
+   e = [t(1), t(2), t(3), t(4), t(5)]
+   e = cshift(e, 3)
+   q = cshift(d, 3)
+   do i = 1, 5
+      if (e(i)%i /= q(i)%i) call abort
+   end do
+
+end program foo