Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

1 files changed, 679 insertions, 0 deletions

diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
new file mode 100644
index 0000000..03edb8f
--- /dev/null
+++ b/gcc/fortran/dependency.c
@@ -0,0 +1,679 @@
+/* Dependency analysis
+   Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of GNU G95.
+
+GNU G95 is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU G95 is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU G95; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* dependency.c -- Expression dependency analysis code.  */
+/* There's probably quite a bit of duplication in this file.  We currently
+   have different dependency checking functions for different types
+   if dependencies.  Ideally these would probably be merged.  */
+   
+
+#include "config.h"
+#include "gfortran.h"
+#include "dependency.h"
+#include <assert.h>
+
+/* static declarations */
+/* Enums  */
+enum range {LHS, RHS, MID};
+
+/* Dependency types.  These must be in reverse order of priority.  */
+typedef enum
+{
+  GFC_DEP_ERROR,
+  GFC_DEP_EQUAL,	/* Identical Ranges.  */
+  GFC_DEP_FORWARD,	/* eg. a(1:3), a(2:4).  */
+  GFC_DEP_OVERLAP,	/* May overlap in some other way.  */
+  GFC_DEP_NODEP		/* Distinct ranges.  */
+}
+gfc_dependency;
+
+/* Macros */
+#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
+
+
+/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
+   def if the value could not be determined.  */
+
+int
+gfc_expr_is_one (gfc_expr * expr, int def)
+{
+  assert (expr != NULL);
+
+  if (expr->expr_type != EXPR_CONSTANT)
+    return def;
+
+  if (expr->ts.type != BT_INTEGER)
+    return def;
+
+  return mpz_cmp_si (expr->value.integer, 1) == 0;
+}
+
+
+/* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
+   and -2 if the relationship could not be determined.  */
+
+int
+gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
+{
+  int i;
+
+  if (e1->expr_type != e2->expr_type)
+    return -2;
+
+  switch (e1->expr_type)
+    {
+    case EXPR_CONSTANT:
+      if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
+	return -2;
+
+      i = mpz_cmp (e1->value.integer, e2->value.integer);
+      if (i == 0)
+	return 0;
+      else if (i < 0)
+	return -1;
+      return 1;
+
+    case EXPR_VARIABLE:
+      if (e1->ref || e2->ref)
+	return -2;
+      if (e1->symtree->n.sym == e2->symtree->n.sym)
+	return 0;
+      return -2;
+
+    default:
+      return -2;
+    }
+}
+
+
+/* Returns 1 if the two ranges are the same, 0 if they are not, and def
+   if the results are indeterminate.  N is the dimension to compare.  */
+
+int
+gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
+{
+  gfc_expr *e1;
+  gfc_expr *e2;
+  int i;
+
+  /* TODO: More sophisticated range comparison.  */
+  assert (ar1 && ar2);
+
+  assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
+
+  e1 = ar1->stride[n];
+  e2 = ar2->stride[n];
+  /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
+  if (e1 && !e2)
+    {
+      i = gfc_expr_is_one (e1, -1);
+      if (i == -1)
+	return def;
+      else if (i == 0)
+	return 0;
+    }
+  else if (e2 && !e1)
+    {
+      i = gfc_expr_is_one (e2, -1);
+      if (i == -1)
+	return def;
+      else if (i == 0)
+	return 0;
+    }
+  else if (e1 && e2)
+    {
+      i = gfc_dep_compare_expr (e1, e2);
+      if (i == -2)
+	return def;
+      else if (i != 0)
+	return 0;
+    }
+  /* The strides match.  */
+
+  /* Check the range start.  */
+  e1 = ar1->start[n];
+  e2 = ar2->start[n];
+
+  if (!(e1 || e2))
+    return 1;
+
+  /* Use the bound of the array if no bound is specified.  */
+  if (ar1->as && !e1)
+    e1 = ar1->as->lower[n];
+
+  if (ar2->as && !e2)
+    e2 = ar2->as->upper[n];
+
+  /* Check we have values for both.  */
+  if (!(e1 && e2))
+    return def;
+
+  i = gfc_dep_compare_expr (e1, e2);
+
+  if (i == -2)
+    return def;
+  else if (i == 0)
+    return 1;
+  return 0;
+}
+
+
+/* Dependency checking for direct function return by reference.
+   Returns true if the arguments of the function depend on the
+   destination.  This is considerably less conservative than other
+   dependencies because many function arguments will already be
+   copied into a temporary.  */
+
+int
+gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
+{
+  gfc_actual_arglist *actual;
+  gfc_ref *ref;
+  gfc_expr *expr;
+  int n;
+
+  assert (dest->expr_type == EXPR_VARIABLE
+	  && fncall->expr_type == EXPR_FUNCTION);
+  assert (fncall->rank > 0);
+
+  for (actual = fncall->value.function.actual; actual; actual = actual->next)
+    {
+      expr = actual->expr;
+
+      /* Skip args which are not present.  */
+      if (!expr)
+	continue;
+
+      /* Non-variable expressions will be allocated temporaries anyway.  */
+      switch (expr->expr_type)
+	{
+	case EXPR_VARIABLE:
+	  if (expr->rank > 1)
+	    {
+	      /* This is an array section.  */
+	      for (ref = expr->ref; ref; ref = ref->next)
+		{
+		  if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+		    break;
+		}
+	      assert (ref);
+	      /* AR_FULL can't contain vector subscripts.  */
+	      if (ref->u.ar.type == AR_SECTION)
+		{
+		  for (n = 0; n < ref->u.ar.dimen; n++)
+		    {
+		      if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+			break;
+		    }
+		  /* Vector subscript array sections will be copied to a
+		     temporary.  */
+		  if (n != ref->u.ar.dimen)
+		    continue;
+		}
+	    }
+
+	  if (gfc_check_dependency (dest, actual->expr, NULL, 0))
+	    return 1;
+	  break;
+
+	case EXPR_ARRAY:
+	  if (gfc_check_dependency (dest, expr, NULL, 0))
+	    return 1;
+	  break;
+
+	default:
+	  break;
+	}
+    }
+
+  return 0;
+}
+
+
+/* Return true if the statement body redefines the condition.  Returns
+   true if expr2 depends on expr1.  expr1 should be a single term
+   suitable for the lhs of an assignment.  The symbols listed in VARS
+   must be considered to have all possible values. All other scalar
+   variables may be considered constant.  Used for forall and where
+   statements.  Also used with functions returning arrays without a
+   temporary.  */
+
+int
+gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars,
+		      int nvars)
+{
+  gfc_ref *ref;
+  int n;
+  gfc_actual_arglist *actual;
+
+  assert (expr1->expr_type == EXPR_VARIABLE);
+
+  /* TODO: -fassume-no-pointer-aliasing */
+  if (expr1->symtree->n.sym->attr.pointer)
+    return 1;
+  for (ref = expr1->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+	return 1;
+    }
+
+  switch (expr2->expr_type)
+    {
+    case EXPR_OP:
+      n = gfc_check_dependency (expr1, expr2->op1, vars, nvars);
+      if (n)
+	return n;
+      if (expr2->op2)
+	return gfc_check_dependency (expr1, expr2->op2, vars, nvars);
+      return 0;
+
+    case EXPR_VARIABLE:
+      if (expr2->symtree->n.sym->attr.pointer)
+	return 1;
+
+      for (ref = expr2->ref; ref; ref = ref->next)
+	{
+	  if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+	    return 1;
+	}
+
+      if (expr1->symtree->n.sym != expr2->symtree->n.sym)
+	return 0;
+
+      for (ref = expr2->ref; ref; ref = ref->next)
+	{
+	  /* Identical ranges return 0, overlapping ranges return 1.  */
+	  if (ref->type == REF_ARRAY)
+	    return 1;
+	}
+      return 1;
+
+    case EXPR_FUNCTION:
+      /* Remember possible differences betweeen elemental and
+         transformational functions.  All functions inside a FORALL
+         will be pure.  */
+      for (actual = expr2->value.function.actual;
+	   actual; actual = actual->next)
+	{
+	  if (!actual->expr)
+	    continue;
+	  n = gfc_check_dependency (expr1, actual->expr, vars, nvars);
+	  if (n)
+	    return n;
+	}
+      return 0;
+
+    case EXPR_CONSTANT:
+      return 0;
+
+    case EXPR_ARRAY:
+      /* Probably ok in the majority of (constant) cases.  */
+      return 1;
+
+    default:
+      return 1;
+    }
+}
+
+
+/* Calculates size of the array reference using lower bound, upper bound
+   and stride.  */
+
+static void
+get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
+{
+  /* nNoOfEle = (u1-l1)/s1  */
+
+  mpz_sub (ele, u1->value.integer, l1->value.integer);
+
+  if (s1 != NULL)
+    mpz_tdiv_q (ele, ele, s1->value.integer);
+}
+
+
+/* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
+
+static gfc_dependency
+get_deps (mpz_t x1, mpz_t x2, mpz_t y)
+{
+  int start;
+  int end;
+
+  start = mpz_cmp_ui (x1, 0);
+  end = mpz_cmp (x2, y);
+  
+  /* Both ranges the same.  */
+  if (start == 0 && end == 0)
+    return GFC_DEP_EQUAL;
+
+  /* Distinct ranges.  */
+  if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
+      || (mpz_cmp (x1, y) > 0 && end > 0))
+    return GFC_DEP_NODEP;
+
+  /* Overlapping, but with corresponding elements of the second range
+     greater than the first.  */
+  if (start > 0 && end > 0)
+    return GFC_DEP_FORWARD;
+
+  /* Overlapping in some other way.  */
+  return GFC_DEP_OVERLAP;
+}
+
+
+/* Transforms a sections l and r such that 
+   (l_start:l_end:l_stride) -> (0:no_of_elements)
+   (r_start:r_end:r_stride) -> (X1:X2)
+   Where r_end is implicit as both sections must have the same number of
+   elelments.
+   Returns 0 on success, 1 of the transformation failed.  */
+/* TODO: Should this be (0:no_of_elements-1) */
+
+static int
+transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
+		    gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
+		    gfc_expr * r_start, gfc_expr * r_stride)
+{
+  if (NULL == l_start || NULL == l_end || NULL == r_start)
+    return 1;
+
+  /* TODO : Currently we check the dependency only when start, end and stride
+    are constant.  We could also check for equal (variable) values, and
+    common subexpressions, eg. x vs. x+1.  */
+
+  if (l_end->expr_type != EXPR_CONSTANT
+      || l_start->expr_type != EXPR_CONSTANT
+      || r_start->expr_type != EXPR_CONSTANT
+      || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
+      || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
+    {
+       return 1;
+    }
+
+
+  get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
+
+  mpz_sub (X1, r_start->value.integer, l_start->value.integer);
+  if (l_stride != NULL)
+    mpz_cdiv_q (X1, X1, l_stride->value.integer);
+  
+  if (r_stride == NULL)
+    mpz_set (X2, no_of_elements);
+  else
+    mpz_mul (X2, no_of_elements, r_stride->value.integer);
+
+  if (l_stride != NULL)
+    mpz_cdiv_q (X2, X2, r_stride->value.integer);
+  mpz_add (X2, X2, X1);
+
+  return 0;
+}
+  
+
+/* Determines overlapping for two array sections.  */
+
+static gfc_dependency
+gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
+{
+  gfc_expr *l_start;
+  gfc_expr *l_end;
+  gfc_expr *l_stride;
+
+  gfc_expr *r_start;
+  gfc_expr *r_stride;
+
+  gfc_array_ref	l_ar;
+  gfc_array_ref	r_ar;
+
+  mpz_t no_of_elements;
+  mpz_t	X1, X2;
+  gfc_dependency dep;
+
+  l_ar = lref->u.ar;
+  r_ar = rref->u.ar;
+
+  l_start = l_ar.start[n];
+  l_end = l_ar.end[n];
+  l_stride = l_ar.stride[n];
+  r_start = r_ar.start[n];
+  r_stride = r_ar.stride[n];
+
+  /* if l_start is NULL take it from array specifier  */
+  if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
+    l_start = l_ar.as->lower[n];
+
+  /* if l_end is NULL take it from array specifier  */
+  if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
+    l_end = l_ar.as->upper[n];
+
+  /* if r_start is NULL take it from array specifier  */
+  if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
+    r_start = r_ar.as->lower[n];
+
+  mpz_init (X1);
+  mpz_init (X2);
+  mpz_init (no_of_elements);
+
+  if (transform_sections (X1, X2, no_of_elements,
+			  l_start, l_end, l_stride,
+			  r_start, r_stride))
+    dep = GFC_DEP_OVERLAP;
+  else
+    dep =  get_deps (X1, X2, no_of_elements);
+
+  mpz_clear (no_of_elements);
+  mpz_clear (X1);
+  mpz_clear (X2);
+  return dep;
+}
+
+
+/* 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);
+}
+
+
+/* Determines overlapping for two single element array references.  */
+
+static gfc_dependency
+gfc_check_element_vs_element (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_dependency nIsDep;
+
+  if (lref->type == REF_ARRAY && rref->type == REF_ARRAY)
+    {
+      l_ar = lref->u.ar;
+      r_ar = rref->u.ar;
+      l_start = l_ar.start[n] ;
+      r_start = r_ar.start[n] ;
+      if (gfc_dep_compare_expr (r_start, l_start) == 0)
+        nIsDep = GFC_DEP_EQUAL;
+      else
+	nIsDep = GFC_DEP_NODEP;
+  }
+  else
+    nIsDep = GFC_DEP_NODEP;
+
+  return nIsDep;
+}
+
+
+/* Finds if two array references are overlapping or not.
+   Return value
+   	1 : array references are overlapping.
+   	0 : array references are not overlapping.  */
+
+int
+gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
+{
+  int n;
+  gfc_dependency fin_dep;
+  gfc_dependency this_dep;
+
+
+  fin_dep = GFC_DEP_ERROR;
+  /* Dependencies due to pointers should already have been identified.
+     We only need to check for overlapping array references.  */
+
+  while (lref && rref)
+    {
+      /* We're resolving from the same base symbol, so both refs should be
+         the same type.  We traverse the reference chain intil we find ranges
+	 that are not equal.  */
+      assert (lref->type == rref->type);
+      switch (lref->type)
+	{
+	case REF_COMPONENT:
+	  /* The two ranges can't overlap if they are from different
+	     components.  */
+	  if (lref->u.c.component != rref->u.c.component)
+	    return 0;
+	  break;
+	  
+	case REF_SUBSTRING:
+	  /* Substring overlaps are handled by the string assignment code.  */
+	  return 0;
+	
+	case REF_ARRAY:
+	  
+	  for (n=0; n < lref->u.ar.dimen; n++)
+	    {
+	      /* Assume dependency when either of array reference is vector
+	         subscript.  */
+	      if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
+		  || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+		return 1;
+	      if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
+		  && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = gfc_check_section_vs_section (lref, rref, n);
+	      else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+		       && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = gfc_check_element_vs_section (lref, rref, n);
+	      else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+		       && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
+		this_dep = gfc_check_element_vs_section (rref, lref, n);
+	      else 
+		{
+		  assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
+		          && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
+		  this_dep = gfc_check_element_vs_element (rref, lref, n);
+		}
+
+	      /* If any dimension doesn't overlap, we have no dependency.  */
+	      if (this_dep == GFC_DEP_NODEP)
+		return 0;
+
+	      /* Overlap codes are in order of priority.  We only need to
+	         know the worst one.*/
+	      if (this_dep > fin_dep)
+		fin_dep = this_dep;
+	    }
+	  /* Exactly matching and forward overlapping ranges don't cause a
+	     dependency.  */
+	  if (fin_dep < GFC_DEP_OVERLAP)
+	    return 0;
+
+	  /* Keep checking.  We only have a dependency if
+	     subsequent references also overlap.  */
+	  break;
+
+	default:
+	  abort();
+	}
+      lref = lref->next;
+      rref = rref->next;
+    }
+
+  /* If we haven't seen any array refs then something went wrong.  */
+  assert (fin_dep != GFC_DEP_ERROR);
+
+  if (fin_dep < GFC_DEP_OVERLAP)
+    return 0;
+  else
+    return 1;
+}
+