dependency.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

/* Dependency analysis
   Copyright (C) 2000, 2001, 2002, 2005 Free Software Foundation, Inc.
   Contributed by Paul Brook <[e-mail]>

This file is part of GCC.

GCC 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.

GCC 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 GCC; see the file COPYING.  If not, write to the Free
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, 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"

/* 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)
{
  gcc_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.  */
  gcc_assert (ar1 && ar2);

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


/* Return true if the result of reference REF can only be constructed
   using a temporary array.  */

bool
gfc_ref_needs_temporary_p (gfc_ref *ref)
{
  int n;
  bool subarray_p;

  subarray_p = false;
  for (; ref; ref = ref->next)
    switch (ref->type)
      {
      case REF_ARRAY:
	/* Vector dimensions are generally not monotonic and must be
	   handled using a temporary.  */
	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)
	      return true;

	subarray_p = true;
	break;

      case REF_SUBSTRING:
	/* Within an array reference, character substrings generally
	   need a temporary.  Character array strides are expressed as
	   multiples of the element size (consistent with other array
	   types), not in characters.  */
	return subarray_p;

      case REF_COMPONENT:
	break;
      }

  return false;
}


/* 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_expr *expr;

  gcc_assert (dest->expr_type == EXPR_VARIABLE
	  && fncall->expr_type == EXPR_FUNCTION);
  gcc_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 (!gfc_ref_needs_temporary_p (expr->ref)
	      && gfc_check_dependency (dest, 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;

  gcc_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->value.op.op1, vars, nvars);
      if (n)
	return n;
      if (expr2->value.op.op2)
	return gfc_check_dependency (expr1, expr2->value.op.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 between 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;
    }
}