re PR fortran/45159 (Unnecessary temporaries)

2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45159
	* gfortran.h (gfc_dep_difference):  Add prototype.
	* dependency.c (discard_nops):  New function.
	(gfc_dep_difference):  New function.
	(check_section_vs_section):  Use gfc_dep_difference
	to calculate the difference of starting indices.
	* trans-expr.c (gfc_conv_substring):  Use
	gfc_dep_difference to calculate the length of
	substrings where possible.

2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45159
	* gfortran.dg/string_length_2.f90:  New test.
	* gfortran.dg/dependency_41.f90:  New test.

From-SVN: r197217

gcc/fortran/ChangeLog

 2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
+	PR fortran/45159
+	* gfortran.h (gfc_dep_difference):  Add prototype.
+	* dependency.c (discard_nops):  New function.
+	(gfc_dep_difference):  New function.
+	(check_section_vs_section):  Use gfc_dep_difference
+	to calculate the difference of starting indices.
+	* trans-expr.c (gfc_conv_substring):  Use
+	gfc_dep_difference to calculate the length of
+	substrings where possible.
+
+2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
 	PR fortran/55806
 	* frontend-passes.c (optimize_code):  Keep track of
 	current code to make code insertion possible.

gcc/fortran/dependency.c

@@ -501,6 +501,272 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
 }
 
 
+/* Helper function to look through parens and unary plus.  */
+
+static gfc_expr*
+discard_nops (gfc_expr *e)
+{
+
+  while (e && e->expr_type == EXPR_OP
+	 && (e->value.op.op == INTRINSIC_UPLUS
+	     || e->value.op.op == INTRINSIC_PARENTHESES))
+    e = e->value.op.op1;
+
+  return e;
+}
+
+
+/* Return the difference between two expressions.  Integer expressions of
+   the form 
+
+   X + constant, X - constant and constant + X
+
+   are handled.  Return true on success, false on failure. result is assumed
+   to be uninitialized on entry, and will be initialized on success.
+*/
+
+bool
+gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
+{
+  gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
+
+  if (e1 == NULL || e2 == NULL)
+    return false;
+
+  if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
+    return false;
+
+  e1 = discard_nops (e1);
+  e2 = discard_nops (e2);
+
+  /* Inizialize tentatively, clear if we don't return anything.  */
+  mpz_init (*result);
+
+  /* Case 1: c1 - c2 = c1 - c2, trivially.  */
+
+  if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
+    {
+      mpz_sub (*result, e1->value.integer, e2->value.integer);
+      return true;
+    }
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
+    {
+      e1_op1 = discard_nops (e1->value.op.op1);
+      e1_op2 = discard_nops (e1->value.op.op2);
+
+      /* Case 2: (X + c1) - X = c1.  */
+      if (e1_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1_op1, e2) == 0)
+	{
+	  mpz_set (*result, e1_op2->value.integer);
+	  return true;
+	}
+
+      /* Case 3: (c1 + X) - X = c1. */
+      if (e1_op1->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1_op2, e2) == 0)
+	{
+	  mpz_set (*result, e1_op1->value.integer);
+	  return true;
+	}
+
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+	{
+	  e2_op1 = discard_nops (e2->value.op.op1);
+	  e2_op2 = discard_nops (e2->value.op.op2);
+
+	  if (e1_op2->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 4: X + c1 - (X + c2) = c1 - c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	      /* Case 5: X + c1 - (c2 + X) = c1 - c2.  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op2->value.integer,
+			   e2_op1->value.integer);
+		  return true;
+		}
+	    }
+	  else if (e1_op1->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 6: c1 + X - (X + c2) = c1 - c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	      /* Case 7: c1 + X - (c2 + X) = c1 - c2.  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op1->value.integer);
+		  return true;
+		}
+	    }
+	}
+
+      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	{
+	  e2_op1 = discard_nops (e2->value.op.op1);
+	  e2_op2 = discard_nops (e2->value.op.op2);
+
+	  if (e1_op2->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 8: X + c1 - (X - c2) = c1 + c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	    }
+	  if (e1_op1->expr_type == EXPR_CONSTANT)
+	    {
+	      /* Case 9: c1 + X - (X - c2) = c1 + c2.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op2, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op1->value.integer,
+			   e2_op2->value.integer);
+		  return true;
+		}
+	    }
+	}
+    }
+
+  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
+    {
+      e1_op1 = discard_nops (e1->value.op.op1);
+      e1_op2 = discard_nops (e1->value.op.op2);
+
+      if (e1_op2->expr_type == EXPR_CONSTANT)
+	{
+	  /* Case 10: (X - c1) - X = -c1  */
+
+	  if (gfc_dep_compare_expr (e1_op1, e2) == 0)
+	    {
+	      mpz_neg (*result, e1_op2->value.integer);
+	      return true;
+	    }
+
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+
+	      /* Case 11: (X - c1) - (X + c2) = -( c1 + c2).  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op2->value.integer);
+		  mpz_neg (*result, *result);
+		  return true;
+		}
+
+	      /* Case 12: X - c1 - (c2 + X) = - (c1 + c2).  */
+	      if (e2_op1->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op2) == 0)
+		{
+		  mpz_add (*result, e1_op2->value.integer,
+			   e2_op1->value.integer);
+		  mpz_neg (*result, *result);
+		  return true;
+		}
+	    }
+
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+
+	      /* Case 13: (X - c1) - (X - c2) = c2 - c1.  */
+	      if (e2_op2->expr_type == EXPR_CONSTANT
+		  && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
+		{
+		  mpz_sub (*result, e2_op2->value.integer,
+			   e1_op2->value.integer);
+		  return true;
+		}
+	    }
+	}
+      if (e1_op1->expr_type == EXPR_CONSTANT)
+	{
+	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+	    {
+	      e2_op1 = discard_nops (e2->value.op.op1);
+	      e2_op2 = discard_nops (e2->value.op.op2);
+	      
+	      /* Case 14: (c1 - X) - (c2 - X) == c1 - c2.  */
+	      if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
+		{
+		  mpz_sub (*result, e1_op1->value.integer,
+			   e2_op1->value.integer);
+		    return true;
+		}
+	    }
+
+	}
+    }
+
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
+    {
+      e2_op1 = discard_nops (e2->value.op.op1);
+      e2_op2 = discard_nops (e2->value.op.op2);
+
+      /* Case 15: X - (X + c2) = -c2.  */
+      if (e2_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op1) == 0)
+	{
+	  mpz_neg (*result, e2_op2->value.integer);
+	  return true;
+	}
+      /* Case 16: X - (c2 + X) = -c2.  */
+      if (e2_op1->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op2) == 0)
+	{
+	  mpz_neg (*result, e2_op1->value.integer);
+	  return true;
+	}
+    }
+
+  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
+    {
+      e2_op1 = discard_nops (e2->value.op.op1);
+      e2_op2 = discard_nops (e2->value.op.op2);
+
+      /* Case 17: X - (X - c2) = c2.  */
+      if (e2_op2->expr_type == EXPR_CONSTANT
+	  && gfc_dep_compare_expr (e1, e2_op1) == 0)
+	{
+	  mpz_set (*result, e2_op2->value.integer);
+	  return true;
+	}
+    }
+
+  if (gfc_dep_compare_expr(e1, e2) == 0)
+    {
+      /* Case 18: X - X = 0.  */
+      mpz_set_si (*result, 0);
+      return true;
+    }
+
+  mpz_clear (*result);
+  return false;
+}
+
 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
    results are indeterminate). 'n' is the dimension to compare.  */
 
@@ -1140,6 +1406,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
   int r_dir;
   int stride_comparison;
   int start_comparison;
+  mpz_t tmp;
 
   /* If they are the same range, return without more ado.  */
   if (is_same_range (l_ar, r_ar, n))
@@ -1275,24 +1542,20 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
      (l_start - r_start) / gcd(l_stride, r_stride) is
      nonzero.
      TODO:
-       - Handle cases where x is an expression.
        - Cases like a(1:4:2) = a(2:3) are still not handled.
   */
 
 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
 			      && (a)->ts.type == BT_INTEGER)
 
-  if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
-      && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
+  if (IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride)
+      && gfc_dep_difference (l_start, r_start, &tmp))
     {
-      mpz_t gcd, tmp;
+      mpz_t gcd;
       int result;
 
       mpz_init (gcd);
-      mpz_init (tmp);
-
       mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
-      mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
 
       mpz_fdiv_r (tmp, tmp, gcd);
       result = mpz_cmp_si (tmp, 0L);

gcc/fortran/gfortran.h

@@ -2969,6 +2969,7 @@ gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 /* dependency.c */
 int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool);
 int gfc_dep_compare_expr (gfc_expr *, gfc_expr *);
+bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *);
 
 /* check.c */
 gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);

gcc/fortran/trans-expr.c

@@ -1437,6 +1437,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
   gfc_se start;
   gfc_se end;
   char *msg;
+  mpz_t length;
 
   type = gfc_get_character_type (kind, ref->u.ss.length);
   type = build_pointer_type (type);
@@ -1520,10 +1521,19 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       free (msg);
     }
 
-  /* If the start and end expressions are equal, the length is one.  */
+  /* Try to calculate the length from the start and end expressions.  */
   if (ref->u.ss.end
-      && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0)
-    tmp = build_int_cst (gfc_charlen_type_node, 1);
+      && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length))
+    {
+      int i_len;
+
+      i_len = mpz_get_si (length) + 1;
+      if (i_len < 0)
+	i_len = 0;
+
+      tmp = build_int_cst (gfc_charlen_type_node, i_len);
+      mpz_clear (length);  /* Was initialized by gfc_dep_difference.  */
+    }
   else
     {
       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node,

gcc/testsuite/ChangeLog

 2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
+	PR fortran/45159
+	* gfortran.dg/string_length_2.f90:  New test.
+	* gfortran.dg/dependency_41.f90:  New test.
+
+2013-03-28  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
 	PR fortran/55806
 	* gfortran.dg/array_constructor_43.f90:  New test.
 	* gfortran.dg/random_seed_3.f90:  New test.

gcc/testsuite/gfortran.dg/dependency_41.f90

+! { dg-do run }
+! { dg-options "-Warray-temporaries" }
+! No temporary should be generated in this case.
+program main
+  implicit none
+  integer :: i,n
+  integer :: a(10)
+  integer :: b(10)
+  do i=1,10
+     a(i) = i
+     b(i) = i
+  end do
+  n = 1
+  ! Same result when assigning to a or b
+  b(n+1:10:4) = a(n+2:8:2)
+  a(n+1:10:4) = a(n+2:8:2)
+  if (any (a/=b)) call abort
+end program main
+

gcc/testsuite/gfortran.dg/string_length_2.f90

+! { dg-run }
+! { dg-options "-fdump-tree-original" }
+! Test that all string length calculations are
+! optimized away.
+program main
+  character (len=999) :: c
+  character (len=5) :: unit
+  unit = '    '
+  read (unit=unit,fmt='(I5)') i   ! Hide from optimizers
+  j = 7
+  c = '123456789'
+  if (len(c(         3        : 5                )) /= 3) call abort ! Case  1
+  if (len(c(     i*(i+1)      :     (i+1)*i + 2  )) /= 3) call abort ! Case  2
+  if (len(c(     i*(i+1)      : 2 + (i+1)*i      )) /= 3) call abort ! Case  3
+  if (len(c(     i*(i+1) + 2  :     (i+1)*i + 3  )) /= 2) call abort ! Case  4
+  if (len(c( 2 + i*(i+1)      :     (i+1)*i + 3  )) /= 2) call abort ! Case  5
+  if (len(c(     i*(i+1) + 2  : 3 + (i+1)*i      )) /= 2) call abort ! Case  6
+  if (len(c( 2 + i*(i+1)      : 3 + (i+1)*i      )) /= 2) call abort ! Case  7
+  if (len(c(     i*(i+1) - 1  :     (i+1)*i + 1  )) /= 3) call abort ! Case  8
+  if (len(c(     i*(i+1) - 1  : 1 + (i+1)*i      )) /= 3) call abort ! Case  9
+  if (len(c(     i*(i+1)      :     (i+1)*i -(-1))) /= 2) call abort ! Case 10
+  if (len(c(     i*(i+1) +(-2):     (i+1)*i - 1  )) /= 2) call abort ! Case 11 
+  if (len(c(     i*(i+1) + 2  :     (i+1)*i -(-4))) /= 3) call abort ! Case 12
+  if (len(c(     i*(i+1) - 3  :     (i+1)*i - 1  )) /= 3) call abort ! Case 13
+  if (len(c(13 - i*(i+1)      :15 - (i+1)*i      )) /= 3) call abort ! Case 14
+  if (len(c(     i*(i+1) +(-1):     (i+1)*i      )) /= 2) call abort ! Case 15
+  if (len(c(-1 + i*(i+1)      :     (i+1)*i      )) /= 2) call abort ! Case 16
+  if (len(c(     i*(i+1) - 2  :     (i+1)*i      )) /= 3) call abort ! Case 17
+  if (len(c(  (i-2)*(i-3)     :   (i-3)*(i-2)    )) /= 1)       call abort ! Case 18
+end program main
+! { dg-final { scan-tree-dump-times "_abort" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }