(Partial) Implementation of simplificaiton of CSHIFT
diff mbox

Message ID 20151120005836.GA53763@troutmask.apl.washington.edu
State New
Headers show

Commit Message

Steve Kargl Nov. 20, 2015, 12:58 a.m. UTC
The attached patch provides a partial implementation for
the simplification for CSHIFT.  It is partial in that it
only applies to rank 1 arrays.  For arrays with rank > 1,
gfc_simplify_cshift will issue an error.  Here, the intent
is that hopefully someone that knows what they are doing
with supply a patch for rank > 1.

The meat of the patch for rank = 1 may not be the most
efficient.  It copies the array elements from 'a' to 'result'
in the circularly shifted order.  It inefficiently always
starts with the first element in 'a' to find the candidate
element for next 'result' element.

      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);
	}

As the values are storied in a splay tree, there may be
a more efficient way to split the splay and recombine
it into a new.

Anyway, I would like to commit the attached patch.
Built and tested on x86_64-*-freebsd?

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.

Comments

Steve Kargl Nov. 20, 2015, 1:31 a.m. UTC | #1
On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote:
> +  else
> +    {
> +      int dm;
> +
> +      if (dim)
> +	{
> +	  if (!gfc_is_constant_expr (dim))
> +	    return NULL;
> +
> +	  dm = mpz_get_si (dim->value.integer);
> +	}
> +      else
> +	dm = 1;
> +
> +      gfc_error ("Simplification of CSHIFT with an array with rank > 1 "
> +	         "no yet support");
> +    }
> +

To save some time, the dim portion of the patch isn't
correct.  dim can be scalar or rank 1 array.  I'll
#if 0 ... #endif this section unless I persevere with
the rank > 1 case.
Steve Kargl Nov. 20, 2015, 3:16 a.m. UTC | #2
On Thu, Nov 19, 2015 at 05:31:32PM -0800, Steve Kargl wrote:
> On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote:
> > +  else
> > +    {
> > +      int dm;
> > +
> > +      if (dim)
> > +	{
> > +	  if (!gfc_is_constant_expr (dim))
> > +	    return NULL;
> > +
> > +	  dm = mpz_get_si (dim->value.integer);
> > +	}
> > +      else
> > +	dm = 1;
> > +
> > +      gfc_error ("Simplification of CSHIFT with an array with rank > 1 "
> > +	         "no yet support");
> > +    }
> > +
> 
> To save some time, the dim portion of the patch isn't
> correct.  dim can be scalar or rank 1 array.  I'll
> #if 0 ... #endif this section unless I persevere with
> the rank > 1 case.

Ugh.  Too much gdb today.  The above is correct.  I conflated
SHIFT and DIM's requirements.

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,88 @@  gfc_simplify_count (gfc_expr *mask, gfc_
 
 
 gfc_expr *
+gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
+{
+  gfc_expr *a;
+
+  a = gfc_copy_expr (array);
+
+  switch (a->expr_type)
+    {
+      case EXPR_VARIABLE:
+      case 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))
+	return NULL;
+
+      shft = mpz_get_si (shift->value.integer);
+
+      /* Special case: rank 1 array with no shift!  */
+      if (shft == 0)
+	return a;
+
+      /*  Case (i):  If ARRAY has rank one, element i of the result is
+	  ARRAY (1 + MODULO (i + SHIFT ­ 1, SIZE (ARRAY))).  */
+
+      result = gfc_copy_expr (a);
+      mpz_init (size);
+      gfc_array_size (a, &size);
+      sz = mpz_get_si (size);
+      mpz_clear (size);
+      shft = shft < 0 ? 1 - shft : shft;
+      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
+    {
+      int dm;
+
+      if (dim)
+	{
+	  if (!gfc_is_constant_expr (dim))
+	    return NULL;
+
+	  dm = mpz_get_si (dim->value.integer);
+	}
+      else
+	dm = 1;
+
+      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 +6171,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,38 @@ 
+! { dg-do compile }
+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
+
+   b = cshift([1, 2, 3, 4, 5], 0)
+   if (any(b /= a)) call abort
+   b = cshift(2*a, 0)
+   if (any(b /= 2*a)) call abort
+ 
+   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