[Fortran] Disambiguate A(I,...) and A(I+1,...)

[Roger Sayle <roger at eyesopen dot com>]

Yet another patch to improve the gfortran front-end's dependency analysis.
The workhorse of gfc_check_dependency is the function gfc_dep_compare_expr
which compares two expressions returning 0 for equality, 1 or -1 if they
are ordered and -2 otherwise.  Currently, ordering is only supported for
integer constants, so this routine can determine "2 < 3".  The patch below
extends this functionality with some minimal symbolic comparison
functionality.  This can be used to determine that "N < N+1" and that
"N+1 < N+2".  The middle-end assumes that pointer arithmetic doesn't
overflow, which I believe is also reasonable in fortran array index
expressions (perhaps a language lawyer can comment).  Alternatively,
(worst case) we could add a new return value -3, indicating that the
two expressions can't be equal, but not specifying their relative
ordering.

Two minor difficulties in the development of this patch.  Once again
I was bitten by __convert_i4_i8 on 64bit platforms (which isn't an
issue on 32bit targets), so I added special support for integral
extensions which are "unary, constant, increasing functions", such that
extend(A) op extend(B) holds if A op B does, where op is either ==,
< and >.  The other gotcha was that we now have to be even more
careful about forall indices (as revealed the fiendish forall_5.f90).


I think some of this analysis is much better performed by the middle-end
using trees, however (i) the middle-end currently doesn't have much
symbolic range analysis, (ii) even simplistic front-end analysis can
have a significant performance impact [for example, yesterday's
20-25% improvement in polyhedron's channel.f90].  Ultimately, its a
front-end design decision whether to use trees or even canonicalize
"X + -C" vs "X - C" or simplify "(X + C1) + C2".  This would simplify
testing that "X - 1 < X + 1" which we still can't do.  Fortunately,
I believe the simplistic analysis below is sufficient to catch the
remaining low hanging fruit in polyhedron.

For example, in nf.f90 we've the following array assignment (in both
NF2DPrecon and NF3DPrecon):

	x(i:i+nx-1) = x(i:i+nx-1) - c*x(i-nx:i-1)

As long as we can show that i-1 < i, we can prove there's no dependency.
Excercise left to reader.  Patch in preparation.


The following patch has been tested on x86_64-unknown-linux-gnu with
a full "make bootstrap", including fortran, and regression tested with
a "make check-gfortran" with no new failures.

Ok for mainline?



2006-03-26  Roger Sayle  <roger@eyesopen.com>

	* dependency.c (gfc_dep_compare_expr): Strip parentheses and unary
	plus operators when comparing expressions.  Handle comparisons of
	the form "X+C vs. X", "X vs. X+C", "X-C vs. X" and "X vs. X-C" where
	C is an integer constant.  Handle comparisons of the form "P+Q vs.
	R+S" and "P-Q vs. R-S".  Handle comparisons of integral extensions
	specially (increasing functions) so extend(A) > extend(B), when A>B.
	(gfc_check_element_vs_element): Move test later, so that we ignore
	the fact that "A < B" or "A > B" when A or B contains a forall index.

	* gfortran.dg/dependency_14.f90: New test case.
	* gfortran.dg/dependency_15.f90: Likewise.
	* gfortran.dg/dependency_16.f90: Likewise.


Index: dependency.c
===================================================================
*** dependency.c	(revision 112377)
--- dependency.c	(working copy)
*************** gfc_expr_is_one (gfc_expr * expr, int de
*** 72,79 ****
--- 72,183 ----
  int
  gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
  {
+   gfc_actual_arglist *args1;
+   gfc_actual_arglist *args2;
    int i;

+   if (e1->expr_type == EXPR_OP
+       && (e1->value.op.operator == INTRINSIC_UPLUS
+           || e1->value.op.operator == INTRINSIC_PARENTHESES))
+     return gfc_dep_compare_expr (e1->value.op.op1, e2);
+   if (e2->expr_type == EXPR_OP
+       && (e2->value.op.operator == INTRINSIC_UPLUS
+           || e2->value.op.operator == INTRINSIC_PARENTHESES))
+     return gfc_dep_compare_expr (e1, e2->value.op.op1);
+
+   if (e1->expr_type == EXPR_OP
+       && e1->value.op.operator == INTRINSIC_PLUS)
+     {
+       /* Compare X+C vs. X.  */
+       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+ 	  && e1->value.op.op2->ts.type == BT_INTEGER
+ 	  && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+ 	return mpz_sgn (e1->value.op.op2->value.integer);
+
+       /* Compare P+Q vs. R+S.  */
+       if (e2->expr_type == EXPR_OP
+ 	  && e2->value.op.operator == INTRINSIC_PLUS)
+ 	{
+ 	  int l, r;
+
+ 	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+ 	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+ 	  if (l == 0 && r == 0)
+ 	    return 0;
+ 	  if (l == 0 && r != -2)
+ 	    return r;
+ 	  if (l != -2 && r == 0)
+ 	    return l;
+ 	  if (l == 1 && r == 1)
+ 	    return 1;
+ 	  if (l == -1 && r == -1)
+ 	    return -1;
+
+ 	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
+ 	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
+ 	  if (l == 0 && r == 0)
+ 	    return 0;
+ 	  if (l == 0 && r != -2)
+ 	    return r;
+ 	  if (l != -2 && r == 0)
+ 	    return l;
+ 	  if (l == 1 && r == 1)
+ 	    return 1;
+ 	  if (l == -1 && r == -1)
+ 	    return -1;
+ 	}
+     }
+
+   /* Compare X vs. X+C.  */
+   if (e2->expr_type == EXPR_OP
+       && e2->value.op.operator == INTRINSIC_PLUS)
+     {
+       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+ 	  && e2->value.op.op2->ts.type == BT_INTEGER
+ 	  && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+ 	return -mpz_sgn (e2->value.op.op2->value.integer);
+     }
+
+   /* Compare X-C vs. X.  */
+   if (e1->expr_type == EXPR_OP
+       && e1->value.op.operator == INTRINSIC_MINUS)
+     {
+       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
+ 	  && e1->value.op.op2->ts.type == BT_INTEGER
+ 	  && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
+ 	return -mpz_sgn (e1->value.op.op2->value.integer);
+
+       /* Compare P-Q vs. R-S.  */
+       if (e2->expr_type == EXPR_OP
+ 	  && e2->value.op.operator == INTRINSIC_MINUS)
+ 	{
+ 	  int l, r;
+
+ 	  l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+ 	  r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
+ 	  if (l == 0 && r == 0)
+ 	    return 0;
+ 	  if (l != -2 && r == 0)
+ 	    return l;
+ 	  if (l == 0 && r != -2)
+ 	    return -r;
+ 	  if (l == 1 && r == -1)
+ 	    return 1;
+ 	  if (l == -1 && r == 1)
+ 	    return -1;
+ 	}
+     }
+
+   /* Compare X vs. X-C.  */
+   if (e2->expr_type == EXPR_OP
+       && e2->value.op.operator == INTRINSIC_MINUS)
+     {
+       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
+ 	  && e2->value.op.op2->ts.type == BT_INTEGER
+ 	  && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
+ 	return mpz_sgn (e2->value.op.op2->value.integer);
+     }
+
    if (e1->expr_type != e2->expr_type)
      return -2;

*************** gfc_dep_compare_expr (gfc_expr * e1, gfc
*** 119,130 ****
--- 223,251 ----
  	  || e1->value.function.isym != e2->value.function.isym)
  	return -2;

+       args1 = e1->value.function.actual;
+       args2 = e2->value.function.actual;
+
        /* We should list the "constant" intrinsic functions.  Those
  	 without side-effects that provide equal results given equal
  	 argument lists.  */
        switch (e1->value.function.isym->generic_id)
  	{
  	case GFC_ISYM_CONVERSION:
+ 	  /* Handle integer extensions specially, as __convert_i4_i8
+ 	     is not only "constant" but also "unary" and "increasing".  */
+ 	  if (args1 && !args1->next
+ 	      && args2 && !args2->next
+ 	      && e1->ts.type == BT_INTEGER
+ 	      && args1->expr->ts.type == BT_INTEGER
+ 	      && e1->ts.kind > args1->expr->ts.kind
+ 	      && e2->ts.type == e1->ts.type
+ 	      && e2->ts.kind == e1->ts.kind
+ 	      && args2->expr->ts.type == args1->expr->ts.type
+ 	      && args2->expr->ts.kind == args2->expr->ts.kind)
+ 	    return gfc_dep_compare_expr (args1->expr, args2->expr);
+ 	  break;
+
  	case GFC_ISYM_REAL:
  	case GFC_ISYM_LOGICAL:
  	case GFC_ISYM_DBLE:
*************** gfc_dep_compare_expr (gfc_expr * e1, gfc
*** 135,152 ****
  	}

        /* Compare the argument lists for equality.  */
!       {
! 	gfc_actual_arglist *args1 = e1->value.function.actual;
! 	gfc_actual_arglist *args2 = e2->value.function.actual;
! 	while (args1 && args2)
! 	  {
! 	    if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
! 	      return -2;
! 	    args1 = args1->next;
! 	    args2 = args2->next;
! 	  }
! 	return (args1 || args2) ? -2 : 0;
!       }

      default:
        return -2;
--- 256,269 ----
  	}

        /* Compare the argument lists for equality.  */
!       while (args1 && args2)
! 	{
! 	  if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
! 	    return -2;
! 	  args1 = args1->next;
! 	  args2 = args2->next;
! 	}
!       return (args1 || args2) ? -2 : 0;

      default:
        return -2;
*************** gfc_check_element_vs_element (gfc_ref *
*** 904,911 ****
    i = gfc_dep_compare_expr (r_start, l_start);
    if (i == 0)
      return GFC_DEP_EQUAL;
-   if (i != -2)
-     return GFC_DEP_NODEP;

    /* Treat two scalar variables as potentially equal.  This allows
       us to prove that a(i,:) and a(j,:) have no dependency.  See
--- 1021,1026 ----
*************** gfc_check_element_vs_element (gfc_ref *
*** 920,925 ****
--- 1035,1042 ----
        || contains_forall_index_p (l_start))
      return GFC_DEP_OVERLAP;

+   if (i != -2)
+     return GFC_DEP_NODEP;
    return GFC_DEP_EQUAL;
  }



! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
subroutine foo(a,i)
  integer, dimension (4,4) :: a
  integer :: i

  where (a(i,1:3) .ne. 0)
    a(i+1,2:4) = 1
  endwhere
end subroutine
! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
subroutine foo(a,i)
  integer, dimension (4,4) :: a
  integer :: i

  where (a(i,1:3) .ne. 0)
    a(i-1,2:4) = 1
  endwhere
end subroutine
! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
subroutine foo(a,i)
  integer, dimension (4,4) :: a
  integer :: i

  where (a(i+1,1:3) .ne. 0)
    a(i+2,2:4) = 1
  endwhere
end subroutine
! { dg-final { scan-tree-dump-times "malloc" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


Roger
--