[Fortran] Fix/rewrite gfc_check_element_vs_section

[Roger Sayle <roger at eyesopen dot com>]

A small mistake in the current mainline implementation of dependency.c's
gfc_check_element_vs_section means that gfortran currently assumes that
any array section/range may potentially alias/overlap any array index.
Currently, this code only attempts to handle integer range bounds and
indices, but a logic error means that it can't even disambiguate simple
cases such as "a(2,...)" vs "a(4:8,...)".

The patch below pretty much rewrites gfc_check_element_vs_section
(and in the process obsoletes gfc_is_inside_range) extending the
functionality and at the same time fixing the above (safe though
pessimistic) bug.

The new code attempts to avoid the previous constraint that the
range bounds and element must be integer constants.  This allows
us to disambiguate "2" from "4:N", "10" from "N:8", and "2" from
"N:4:-1", and even "3" from "5:9:N".  Using the pending symbolic
expression comparison patch, this change should also handle things
such as "N-1" vs "N:N+6".

The following patch has been tested on x86_64-unknown-linux-gnu
with a full "make bootstrap", including fortran, and regression
tested with a top-level "make -k check" with no new failures.
The testcase below which demonstrates the current pessimization,
passes with this patch but fails without.

Ok for mainline?



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

	* dependency.c (gfc_is_inside_range): Delete.
	(gfc_check_element_vs_section): Significant rewrite.

	* gfortran.dg/dependencency_17.f90: New test case.


Index: dependency.c
===================================================================
*** dependency.c	(revision 112377)
--- dependency.c	(working copy)
*************** gfc_check_section_vs_section (gfc_ref *
*** 741,810 ****
  }


! /* Checks if the expr chk is inside the range left-right.
!    Returns  GFC_DEP_NODEP if chk is outside the range,
!    GFC_DEP_OVERLAP otherwise.
!    Assumes left<=right.  */

  static gfc_dependency
! gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
  {
!   int l;
!   int r;
    int s;

!   s = gfc_dep_compare_expr (left, right);
!   if (s == -2)
      return GFC_DEP_OVERLAP;

!   l = gfc_dep_compare_expr (chk, left);
!   r = gfc_dep_compare_expr (chk, right);

!   /* Check for indeterminate relationships.  */
!   if (l == -2 || r == -2 || s == -2)
      return GFC_DEP_OVERLAP;

    if (s == 1)
      {
!       /* When left>right we want to check for right <= chk <= left.  */
!       if (l <= 0 || r >= 0)
! 	return GFC_DEP_OVERLAP;
      }
    else
      {
!       /* Otherwise check for left <= chk <= right.  */
!       if (l >= 0 || r <= 0)
  	return GFC_DEP_OVERLAP;
      }
-
-   return GFC_DEP_NODEP;
- }
-
-
- /* Determines overlapping for a single element and a section.  */
-
- static gfc_dependency
- gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
- {
-   gfc_array_ref l_ar;
-   gfc_array_ref r_ar;
-   gfc_expr *l_start;
-   gfc_expr *r_start;
-   gfc_expr *r_end;
-
-   l_ar = lref->u.ar;
-   r_ar = rref->u.ar;
-   l_start = l_ar.start[n] ;
-   r_start = r_ar.start[n] ;
-   r_end = r_ar.end[n] ;
-   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
-     r_start = r_ar.as->lower[n];
-   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
-     r_end = r_ar.as->upper[n];
-   if (NULL == r_start || NULL == r_end || l_start == NULL)
-     return GFC_DEP_OVERLAP;

!   return gfc_is_inside_range (l_start, r_end, r_start);
  }


--- 741,865 ----
  }


! /* Determines overlapping for a single element and a section.  */

  static gfc_dependency
! gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
  {
!   gfc_array_ref *ref;
!   gfc_expr *elem;
!   gfc_expr *start;
!   gfc_expr *end;
!   gfc_expr *stride;
    int s;

!   elem = lref->u.ar.start[n];
!   if (!elem)
      return GFC_DEP_OVERLAP;

!   ref = &rref->u.ar;
!   start = ref->start[n] ;
!   end = ref->end[n] ;
!   stride = ref->stride[n];
!
!   if (!start && IS_ARRAY_EXPLICIT (ref->as))
!     start = ref->as->lower[n];
!   if (!end && IS_ARRAY_EXPLICIT (ref->as))
!     end = ref->as->upper[n];
!
!   /* Determine whether the stride is positive or negative.  */
!   if (!stride)
!     s = 1;
!   else if (stride->expr_type == EXPR_CONSTANT
! 	   && stride->ts.type == BT_INTEGER)
!     s = mpz_sgn (stride->value.integer);
!   else
!     s = -2;

!   /* Stride should never be zero.  */
!   if (s == 0)
      return GFC_DEP_OVERLAP;

+   /* Positive strides.  */
    if (s == 1)
      {
!       /* Check for elem < lower.  */
!       if (start && gfc_dep_compare_expr (elem, start) == -1)
! 	return GFC_DEP_NODEP;
!       /* Check for elem > upper.  */
!       if (end && gfc_dep_compare_expr (elem, end) == 1)
! 	return GFC_DEP_NODEP;
!
!       if (start && end)
! 	{
! 	  s = gfc_dep_compare_expr (start, end);
! 	  /* Check for an empty range.  */
! 	  if (s == 1)
! 	    return GFC_DEP_NODEP;
! 	  if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
! 	    return GFC_DEP_EQUAL;
! 	}
      }
+   /* Negative strides.  */
+   else if (s == -1)
+     {
+       /* Check for elem > upper.  */
+       if (end && gfc_dep_compare_expr (elem, start) == 1)
+ 	return GFC_DEP_NODEP;
+       /* Check for elem < lower.  */
+       if (start && gfc_dep_compare_expr (elem, end) == -1)
+ 	return GFC_DEP_NODEP;
+
+       if (start && end)
+ 	{
+ 	  s = gfc_dep_compare_expr (start, end);
+ 	  /* Check for an empty range.  */
+ 	  if (s == -1)
+ 	    return GFC_DEP_NODEP;
+ 	  if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
+ 	    return GFC_DEP_EQUAL;
+ 	}
+     }
+   /* Unknown strides.  */
    else
      {
!       if (!start || !end)
! 	return GFC_DEP_OVERLAP;
!       s = gfc_dep_compare_expr (start, end);
!       if (s == -2)
  	return GFC_DEP_OVERLAP;
+       /* Assume positive stride.  */
+       if (s == -1)
+ 	{
+ 	  /* Check for elem < lower.  */
+ 	  if (gfc_dep_compare_expr (elem, start) == -1)
+ 	    return GFC_DEP_NODEP;
+ 	  /* Check for elem > upper.  */
+ 	  if (gfc_dep_compare_expr (elem, end) == 1)
+ 	    return GFC_DEP_NODEP;
+ 	}
+       /* Assume negative stride.  */
+       else if (s == 1)
+ 	{
+ 	  /* Check for elem > upper.  */
+ 	  if (gfc_dep_compare_expr (elem, start) == 1)
+ 	    return GFC_DEP_NODEP;
+ 	  /* Check for elem < lower.  */
+ 	  if (gfc_dep_compare_expr (elem, end) == -1)
+ 	    return GFC_DEP_NODEP;
+ 	}
+       /* Equal bounds.  */
+       else if (s == 0)
+ 	{
+ 	  s = gfc_dep_compare_expr (elem, start);
+ 	  if (s == 0)
+ 	    return GFC_DEP_EQUAL;
+ 	  if (s == 1 || s == -1)
+ 	    return GFC_DEP_NODEP;
+ 	}
      }

!   return GFC_DEP_OVERLAP;
  }



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

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


Roger
--