/* Dependency analysis
- Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
-This file is part of GNU G95.
+This file is part of GCC.
-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.
+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 3, 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.
+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 GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* 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 "system.h"
#include "gfortran.h"
#include "dependency.h"
-#include <assert.h>
+#include "constructor.h"
+#include "arith.h"
/* static declarations */
/* Enums */
{
GFC_DEP_ERROR,
GFC_DEP_EQUAL, /* Identical Ranges. */
- GFC_DEP_FORWARD, /* eg. a(1:3), a(2:4). */
+ GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */
+ GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */
GFC_DEP_OVERLAP, /* May overlap in some other way. */
GFC_DEP_NODEP /* Distinct ranges. */
}
/* Macros */
#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
+/* Forward declarations */
+
+static gfc_dependency check_section_vs_section (gfc_array_ref *,
+ gfc_array_ref *, int);
/* 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)
+gfc_expr_is_one (gfc_expr *expr, int def)
{
- assert (expr != NULL);
+ gcc_assert (expr != NULL);
if (expr->expr_type != EXPR_CONSTANT)
return def;
return mpz_cmp_si (expr->value.integer, 1) == 0;
}
+/* Check if two array references are known to be identical. Calls
+ gfc_dep_compare_expr if necessary for comparing array indices. */
+
+static bool
+identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
+{
+ int i;
+
+ if (a1->type == AR_FULL && a2->type == AR_FULL)
+ return true;
+
+ if (a1->type == AR_SECTION && a2->type == AR_SECTION)
+ {
+ gcc_assert (a1->dimen == a2->dimen);
+
+ for ( i = 0; i < a1->dimen; i++)
+ {
+ /* TODO: Currently, we punt on an integer array as an index. */
+ if (a1->dimen_type[i] != DIMEN_RANGE
+ || a2->dimen_type[i] != DIMEN_RANGE)
+ return false;
+
+ if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
+ return false;
+ }
+ return true;
+ }
+
+ if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
+ {
+ gcc_assert (a1->dimen == a2->dimen);
+ for (i = 0; i < a1->dimen; i++)
+ {
+ if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
+ return false;
+ }
+ return true;
+ }
+ return false;
+}
+
+
+
+/* Return true for identical variables, checking for references if
+ necessary. Calls identical_array_ref for checking array sections. */
+
+static bool
+are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+{
+ gfc_ref *r1, *r2;
+
+ if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
+ {
+ /* Dummy arguments: Only check for equal names. */
+ if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
+ return false;
+ }
+ else
+ {
+ /* Check for equal symbols. */
+ if (e1->symtree->n.sym != e2->symtree->n.sym)
+ return false;
+ }
+
+ /* Volatile variables should never compare equal to themselves. */
+
+ if (e1->symtree->n.sym->attr.volatile_)
+ return false;
+
+ r1 = e1->ref;
+ r2 = e2->ref;
+
+ while (r1 != NULL || r2 != NULL)
+ {
+
+ /* Assume the variables are not equal if one has a reference and the
+ other doesn't.
+ TODO: Handle full references like comparing a(:) to a.
+ */
+
+ if (r1 == NULL || r2 == NULL)
+ return false;
+
+ if (r1->type != r2->type)
+ return false;
+
+ switch (r1->type)
+ {
+
+ case REF_ARRAY:
+ if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
+ return false;
+
+ break;
+
+ case REF_COMPONENT:
+ if (r1->u.c.component != r2->u.c.component)
+ return false;
+ break;
+
+ case REF_SUBSTRING:
+ if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0
+ || gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
+ return false;
+ break;
+
+ default:
+ gfc_internal_error ("are_identical_variables: Bad type");
+ }
+ r1 = r1->next;
+ r2 = r2->next;
+ }
+ return true;
+}
+
+/* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
+ impure_ok is false, only return 0 for pure functions. */
-/* 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_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
+{
+
+ gfc_actual_arglist *args1;
+ gfc_actual_arglist *args2;
+
+ if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
+ return -2;
+
+ if ((e1->value.function.esym && e2->value.function.esym
+ && e1->value.function.esym == e2->value.function.esym
+ && (e1->value.function.esym->result->attr.pure || impure_ok))
+ || (e1->value.function.isym && e2->value.function.isym
+ && e1->value.function.isym == e2->value.function.isym
+ && (e1->value.function.isym->pure || impure_ok)))
+ {
+ args1 = e1->value.function.actual;
+ args2 = e2->value.function.actual;
+
+ /* Compare the argument lists for equality. */
+ while (args1 && args2)
+ {
+ /* Bitwise xor, since C has no non-bitwise xor operator. */
+ if ((args1->expr == NULL) ^ (args2->expr == NULL))
+ return -2;
+
+ if (args1->expr != NULL && args2->expr != NULL
+ && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+ return -2;
+
+ args1 = args1->next;
+ args2 = args2->next;
+ }
+ return (args1 || args2) ? -2 : 0;
+ }
+ else
+ return -2;
+}
+
+/* Compare two expressions. Return values:
+ * +1 if e1 > e2
+ * 0 if e1 == e2
+ * -1 if e1 < e2
+ * -2 if the relationship could not be determined
+ * -3 if e1 /= e2, but we cannot tell which one is larger. */
int
-gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
+gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
{
+ gfc_actual_arglist *args1;
+ gfc_actual_arglist *args2;
int i;
+ gfc_expr *n1, *n2;
+
+ n1 = NULL;
+ n2 = NULL;
+
+ /* Remove any integer conversion functions to larger types. */
+ if (e1->expr_type == EXPR_FUNCTION && e1->value.function.isym
+ && e1->value.function.isym->id == GFC_ISYM_CONVERSION
+ && e1->ts.type == BT_INTEGER)
+ {
+ args1 = e1->value.function.actual;
+ if (args1->expr->ts.type == BT_INTEGER
+ && e1->ts.kind > args1->expr->ts.kind)
+ n1 = args1->expr;
+ }
+
+ if (e2->expr_type == EXPR_FUNCTION && e2->value.function.isym
+ && e2->value.function.isym->id == GFC_ISYM_CONVERSION
+ && e2->ts.type == BT_INTEGER)
+ {
+ args2 = e2->value.function.actual;
+ if (args2->expr->ts.type == BT_INTEGER
+ && e2->ts.kind > args2->expr->ts.kind)
+ n2 = args2->expr;
+ }
+
+ if (n1 != NULL)
+ {
+ if (n2 != NULL)
+ return gfc_dep_compare_expr (n1, n2);
+ else
+ return gfc_dep_compare_expr (n1, e2);
+ }
+ else
+ {
+ if (n2 != NULL)
+ return gfc_dep_compare_expr (e1, n2);
+ }
+
+ if (e1->expr_type == EXPR_OP
+ && (e1->value.op.op == INTRINSIC_UPLUS
+ || e1->value.op.op == INTRINSIC_PARENTHESES))
+ return gfc_dep_compare_expr (e1->value.op.op1, e2);
+ if (e2->expr_type == EXPR_OP
+ && (e2->value.op.op == INTRINSIC_UPLUS
+ || e2->value.op.op == INTRINSIC_PARENTHESES))
+ return gfc_dep_compare_expr (e1, e2->value.op.op1);
+
+ if (e1->expr_type == EXPR_OP && e1->value.op.op == 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.op == 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.op == 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.op == 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.op == 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 A // B vs. C // D. */
+
+ if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
+ && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
+ {
+ 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 <= -2)
+ return l;
+
+ if (l == 0)
+ {
+ /* Watch out for 'A ' // x vs. 'A' // x. */
+ gfc_expr *e1_left = e1->value.op.op1;
+ gfc_expr *e2_left = e2->value.op.op1;
+
+ if (e1_left->expr_type == EXPR_CONSTANT
+ && e2_left->expr_type == EXPR_CONSTANT
+ && e1_left->value.character.length
+ != e2_left->value.character.length)
+ return -2;
+ else
+ return r;
+ }
+ else
+ {
+ if (l != 0)
+ return l;
+ else
+ return r;
+ }
+ }
+
+ /* Compare X vs. X-C. */
+ if (e2->expr_type == EXPR_OP && e2->value.op.op == 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;
+ return -3;
switch (e1->expr_type)
{
case EXPR_CONSTANT:
+ /* Compare strings for equality. */
+ if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
+ return gfc_compare_string (e1, e2);
+
if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
return -2;
return 1;
case EXPR_VARIABLE:
- if (e1->ref || e2->ref)
+ if (are_identical_variables (e1, e2))
+ return 0;
+ else
+ return -3;
+
+ case EXPR_OP:
+ /* Intrinsic operators are the same if their operands are the same. */
+ if (e1->value.op.op != e2->value.op.op)
return -2;
- if (e1->symtree->n.sym == e2->symtree->n.sym)
+ if (e1->value.op.op2 == 0)
+ {
+ i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
+ return i == 0 ? 0 : -2;
+ }
+ if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
+ && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
+ return 0;
+ else if (e1->value.op.op == INTRINSIC_TIMES
+ && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
+ && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0)
+ /* Commutativity of multiplication. */
return 0;
+
return -2;
+ case EXPR_FUNCTION:
+ return gfc_dep_compare_functions (e1, e2, false);
+ break;
+
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. */
+/* 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. */
-int
-gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
+static int
+is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
{
gfc_expr *e1;
gfc_expr *e2;
int i;
/* TODO: More sophisticated range comparison. */
- assert (ar1 && ar2);
+ gcc_assert (ar1 && ar2);
- assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
+ gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
e1 = ar1->stride[n];
e2 = ar2->stride[n];
if (e1 && !e2)
{
i = gfc_expr_is_one (e1, -1);
- if (i == -1)
- return def;
- else if (i == 0)
+ if (i == -1 || i == 0)
return 0;
}
else if (e2 && !e1)
{
i = gfc_expr_is_one (e2, -1);
- if (i == -1)
- return def;
- else if (i == 0)
+ if (i == -1 || i == 0)
return 0;
}
else if (e1 && e2)
{
i = gfc_dep_compare_expr (e1, e2);
- if (i == -2)
- return def;
- else if (i != 0)
+ if (i != 0)
return 0;
}
/* The strides match. */
/* Check the range start. */
e1 = ar1->start[n];
e2 = ar2->start[n];
+ if (e1 || e2)
+ {
+ /* Use the bound of the array if no bound is specified. */
+ if (ar1->as && !e1)
+ e1 = ar1->as->lower[n];
- if (!(e1 || e2))
- return 1;
+ if (ar2->as && !e2)
+ e2 = ar2->as->lower[n];
- /* Use the bound of the array if no bound is specified. */
- if (ar1->as && !e1)
- e1 = ar1->as->lower[n];
+ /* Check we have values for both. */
+ if (!(e1 && e2))
+ return 0;
- if (ar2->as && !e2)
- e2 = ar2->as->upper[n];
+ i = gfc_dep_compare_expr (e1, e2);
+ if (i != 0)
+ return 0;
+ }
- /* Check we have values for both. */
- if (!(e1 && e2))
- return def;
+ /* Check the range end. */
+ e1 = ar1->end[n];
+ e2 = ar2->end[n];
+ if (e1 || e2)
+ {
+ /* Use the bound of the array if no bound is specified. */
+ if (ar1->as && !e1)
+ e1 = ar1->as->upper[n];
- i = gfc_dep_compare_expr (e1, e2);
+ if (ar2->as && !e2)
+ e2 = ar2->as->upper[n];
- if (i == -2)
- return def;
- else if (i == 0)
+ /* Check we have values for both. */
+ if (!(e1 && e2))
+ return 0;
+
+ i = gfc_dep_compare_expr (e1, e2);
+ if (i != 0)
+ return 0;
+ }
+
+ return 1;
+}
+
+
+/* Some array-returning intrinsics can be implemented by reusing the
+ data from one of the array arguments. For example, TRANSPOSE does
+ not necessarily need to allocate new data: it can be implemented
+ by copying the original array's descriptor and simply swapping the
+ two dimension specifications.
+
+ If EXPR is a call to such an intrinsic, return the argument
+ whose data can be reused, otherwise return NULL. */
+
+gfc_expr *
+gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
+{
+ if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
+ return NULL;
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return expr->value.function.actual->expr;
+
+ default:
+ return NULL;
+ }
+}
+
+
+/* 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;
+}
+
+
+static int
+gfc_is_data_pointer (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* No subreference if it is a function */
+ gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
+
+ if (e->symtree->n.sym->attr.pointer)
return 1;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+ 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. */
+/* Return true if array variable VAR could be passed to the same function
+ as argument EXPR without interfering with EXPR. INTENT is the intent
+ of VAR.
+
+ This is considerably less conservative than other dependencies
+ because many function arguments will already be copied into a
+ temporary. */
+
+static int
+gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
+ gfc_expr *expr, gfc_dep_check elemental)
+{
+ gfc_expr *arg;
+
+ gcc_assert (var->expr_type == EXPR_VARIABLE);
+ gcc_assert (var->rank > 0);
+
+ switch (expr->expr_type)
+ {
+ case EXPR_VARIABLE:
+ /* In case of elemental subroutines, there is no dependency
+ between two same-range array references. */
+ if (gfc_ref_needs_temporary_p (expr->ref)
+ || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
+ {
+ if (elemental == ELEM_DONT_CHECK_VARIABLE)
+ {
+ /* Too many false positive with pointers. */
+ if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
+ {
+ /* Elemental procedures forbid unspecified intents,
+ and we don't check dependencies for INTENT_IN args. */
+ gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
+
+ /* We are told not to check dependencies.
+ We do it, however, and issue a warning in case we find one.
+ If a dependency is found in the case
+ elemental == ELEM_CHECK_VARIABLE, we will generate
+ a temporary, so we don't need to bother the user. */
+ gfc_warning ("INTENT(%s) actual argument at %L might "
+ "interfere with actual argument at %L.",
+ intent == INTENT_OUT ? "OUT" : "INOUT",
+ &var->where, &expr->where);
+ }
+ return 0;
+ }
+ else
+ return 1;
+ }
+ return 0;
+
+ case EXPR_ARRAY:
+ return gfc_check_dependency (var, expr, 1);
+
+ case EXPR_FUNCTION:
+ if (intent != INTENT_IN)
+ {
+ arg = gfc_get_noncopying_intrinsic_argument (expr);
+ if (arg != NULL)
+ return gfc_check_argument_var_dependency (var, intent, arg,
+ NOT_ELEMENTAL);
+ }
+
+ if (elemental != NOT_ELEMENTAL)
+ {
+ if ((expr->value.function.esym
+ && expr->value.function.esym->attr.elemental)
+ || (expr->value.function.isym
+ && expr->value.function.isym->elemental))
+ return gfc_check_fncall_dependency (var, intent, NULL,
+ expr->value.function.actual,
+ ELEM_CHECK_VARIABLE);
+
+ if (gfc_inline_intrinsic_function_p (expr))
+ {
+ /* The TRANSPOSE case should have been caught in the
+ noncopying intrinsic case above. */
+ gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
+
+ return gfc_check_fncall_dependency (var, intent, NULL,
+ expr->value.function.actual,
+ ELEM_CHECK_VARIABLE);
+ }
+ }
+ return 0;
+
+ case EXPR_OP:
+ /* In case of non-elemental procedures, there is no need to catch
+ dependencies, as we will make a temporary anyway. */
+ if (elemental)
+ {
+ /* If the actual arg EXPR is an expression, we need to catch
+ a dependency between variables in EXPR and VAR,
+ an intent((IN)OUT) variable. */
+ if (expr->value.op.op1
+ && gfc_check_argument_var_dependency (var, intent,
+ expr->value.op.op1,
+ ELEM_CHECK_VARIABLE))
+ return 1;
+ else if (expr->value.op.op2
+ && gfc_check_argument_var_dependency (var, intent,
+ expr->value.op.op2,
+ ELEM_CHECK_VARIABLE))
+ return 1;
+ }
+ return 0;
+
+ default:
+ return 0;
+ }
+}
+
+
+/* Like gfc_check_argument_var_dependency, but extended to any
+ array expression OTHER, not just variables. */
+
+static int
+gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
+ gfc_expr *expr, gfc_dep_check elemental)
+{
+ switch (other->expr_type)
+ {
+ case EXPR_VARIABLE:
+ return gfc_check_argument_var_dependency (other, intent, expr, elemental);
+
+ case EXPR_FUNCTION:
+ other = gfc_get_noncopying_intrinsic_argument (other);
+ if (other != NULL)
+ return gfc_check_argument_dependency (other, INTENT_IN, expr,
+ NOT_ELEMENTAL);
+
+ return 0;
+
+ default:
+ return 0;
+ }
+}
+
+
+/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
+ FNSYM is the function being called, or NULL if not known. */
int
-gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
+gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
+ gfc_symbol *fnsym, gfc_actual_arglist *actual,
+ gfc_dep_check elemental)
{
- gfc_actual_arglist *actual;
- gfc_ref *ref;
+ gfc_formal_arglist *formal;
gfc_expr *expr;
- int n;
- assert (dest->expr_type == EXPR_VARIABLE
- && fncall->expr_type == EXPR_FUNCTION);
- assert (fncall->rank > 0);
+ formal = fnsym ? fnsym->formal : NULL;
+ for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
+ {
+ expr = actual->expr;
+
+ /* Skip args which are not present. */
+ if (!expr)
+ continue;
+
+ /* Skip other itself. */
+ if (expr == other)
+ continue;
+
+ /* Skip intent(in) arguments if OTHER itself is intent(in). */
+ if (formal && intent == INTENT_IN
+ && formal->sym->attr.intent == INTENT_IN)
+ continue;
+
+ if (gfc_check_argument_dependency (other, intent, expr, elemental))
+ return 1;
+ }
+
+ return 0;
+}
+
+
+/* Return 1 if e1 and e2 are equivalenced arrays, either
+ directly or indirectly; i.e., equivalence (a,b) for a and b
+ or equivalence (a,c),(b,c). This function uses the equiv_
+ lists, generated in trans-common(add_equivalences), that are
+ guaranteed to pick up indirect equivalences. We explicitly
+ check for overlap using the offset and length of the equivalence.
+ This function is symmetric.
+ TODO: This function only checks whether the full top-level
+ symbols overlap. An improved implementation could inspect
+ e1->ref and e2->ref to determine whether the actually accessed
+ portions of these variables/arrays potentially overlap. */
+
+int
+gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
+{
+ gfc_equiv_list *l;
+ gfc_equiv_info *s, *fl1, *fl2;
+
+ gcc_assert (e1->expr_type == EXPR_VARIABLE
+ && e2->expr_type == EXPR_VARIABLE);
+
+ if (!e1->symtree->n.sym->attr.in_equivalence
+ || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
+ return 0;
+
+ if (e1->symtree->n.sym->ns
+ && e1->symtree->n.sym->ns != gfc_current_ns)
+ l = e1->symtree->n.sym->ns->equiv_lists;
+ else
+ l = gfc_current_ns->equiv_lists;
+
+ /* Go through the equiv_lists and return 1 if the variables
+ e1 and e2 are members of the same group and satisfy the
+ requirement on their relative offsets. */
+ for (; l; l = l->next)
+ {
+ fl1 = NULL;
+ fl2 = NULL;
+ for (s = l->equiv; s; s = s->next)
+ {
+ if (s->sym == e1->symtree->n.sym)
+ {
+ fl1 = s;
+ if (fl2)
+ break;
+ }
+ if (s->sym == e2->symtree->n.sym)
+ {
+ fl2 = s;
+ if (fl1)
+ break;
+ }
+ }
+
+ if (s)
+ {
+ /* Can these lengths be zero? */
+ if (fl1->length <= 0 || fl2->length <= 0)
+ return 1;
+ /* These can't overlap if [f11,fl1+length] is before
+ [fl2,fl2+length], or [fl2,fl2+length] is before
+ [fl1,fl1+length], otherwise they do overlap. */
+ if (fl1->offset + fl1->length > fl2->offset
+ && fl2->offset + fl2->length > fl1->offset)
+ return 1;
+ }
+ }
+ return 0;
+}
+
+
+/* Return true if there is no possibility of aliasing because of a type
+ mismatch between all the possible pointer references and the
+ potential target. Note that this function is asymmetric in the
+ arguments and so must be called twice with the arguments exchanged. */
+
+static bool
+check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
+{
+ gfc_component *cm1;
+ gfc_symbol *sym1;
+ gfc_symbol *sym2;
+ gfc_ref *ref1;
+ bool seen_component_ref;
+
+ if (expr1->expr_type != EXPR_VARIABLE
+ || expr1->expr_type != EXPR_VARIABLE)
+ return false;
+
+ sym1 = expr1->symtree->n.sym;
+ sym2 = expr2->symtree->n.sym;
+
+ /* Keep it simple for now. */
+ if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
+ return false;
+
+ if (sym1->attr.pointer)
+ {
+ if (gfc_compare_types (&sym1->ts, &sym2->ts))
+ return false;
+ }
- for (actual = fncall->value.function.actual; actual; actual = actual->next)
+ /* This is a conservative check on the components of the derived type
+ if no component references have been seen. Since we will not dig
+ into the components of derived type components, we play it safe by
+ returning false. First we check the reference chain and then, if
+ no component references have been seen, the components. */
+ seen_component_ref = false;
+ if (sym1->ts.type == BT_DERIVED)
{
- expr = actual->expr;
+ for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
+ {
+ if (ref1->type != REF_COMPONENT)
+ continue;
- /* Skip args which are not present. */
- if (!expr)
- continue;
+ if (ref1->u.c.component->ts.type == BT_DERIVED)
+ return false;
- /* 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 ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
+ && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
+ return false;
- if (gfc_check_dependency (dest, actual->expr, NULL, 0))
- return 1;
- break;
+ seen_component_ref = true;
+ }
+ }
- case EXPR_ARRAY:
- if (gfc_check_dependency (dest, expr, NULL, 0))
- return 1;
- break;
+ if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
+ {
+ for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
+ {
+ if (cm1->ts.type == BT_DERIVED)
+ return false;
- default:
- break;
+ if ((sym2->attr.pointer || cm1->attr.pointer)
+ && gfc_compare_types (&cm1->ts, &sym2->ts))
+ return false;
}
}
- return 0;
+ return true;
}
/* 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
+ suitable for the lhs of an assignment. The IDENTICAL flag indicates
+ whether array references to the same symbol with identical range
+ references count as a dependency or not. 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_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
{
- gfc_ref *ref;
- int n;
gfc_actual_arglist *actual;
+ gfc_constructor *c;
+ int n;
- 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;
- }
+ gcc_assert (expr1->expr_type == EXPR_VARIABLE);
switch (expr2->expr_type)
{
case EXPR_OP:
- n = gfc_check_dependency (expr1, expr2->op1, vars, nvars);
+ n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
if (n)
return n;
- if (expr2->op2)
- return gfc_check_dependency (expr1, expr2->op2, vars, nvars);
+ if (expr2->value.op.op2)
+ return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
return 0;
case EXPR_VARIABLE:
- if (expr2->symtree->n.sym->attr.pointer)
- return 1;
-
- for (ref = expr2->ref; ref; ref = ref->next)
+ /* The interesting cases are when the symbols don't match. */
+ if (expr1->symtree->n.sym != expr2->symtree->n.sym)
{
- if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+ gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
+ gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
+
+ /* Return 1 if expr1 and expr2 are equivalenced arrays. */
+ if (gfc_are_equivalenced_arrays (expr1, expr2))
return 1;
- }
- if (expr1->symtree->n.sym != expr2->symtree->n.sym)
- return 0;
+ /* Symbols can only alias if they have the same type. */
+ if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
+ && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
+ {
+ if (ts1->type != ts2->type || ts1->kind != ts2->kind)
+ 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;
+ /* If either variable is a pointer, assume the worst. */
+ /* TODO: -fassume-no-pointer-aliasing */
+ if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
+ {
+ if (check_data_pointer_types (expr1, expr2)
+ && check_data_pointer_types (expr2, expr1))
+ return 0;
+
+ return 1;
+ }
+ else
+ {
+ gfc_symbol *sym1 = expr1->symtree->n.sym;
+ gfc_symbol *sym2 = expr2->symtree->n.sym;
+ if (sym1->attr.target && sym2->attr.target
+ && ((sym1->attr.dummy && !sym1->attr.contiguous
+ && (!sym1->attr.dimension
+ || sym2->as->type == AS_ASSUMED_SHAPE))
+ || (sym2->attr.dummy && !sym2->attr.contiguous
+ && (!sym2->attr.dimension
+ || sym2->as->type == AS_ASSUMED_SHAPE))))
+ return 1;
+ }
+
+ /* Otherwise distinct symbols have no dependencies. */
+ return 0;
}
+
+ if (identical)
+ return 1;
+
+ /* Identical and disjoint ranges return 0,
+ overlapping ranges return 1. */
+ if (expr1->ref && expr2->ref)
+ return gfc_dep_resolver (expr1->ref, expr2->ref, NULL);
+
return 1;
case EXPR_FUNCTION:
- /* Remember possible differences betweeen elemental and
- transformational functions. All functions inside a FORALL
- will be pure. */
+ if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
+ identical = 1;
+
+ /* 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);
+ n = gfc_check_dependency (expr1, actual->expr, identical);
if (n)
return n;
}
return 0;
case EXPR_CONSTANT:
+ case EXPR_NULL:
return 0;
case EXPR_ARRAY:
- /* Probably ok in the majority of (constant) cases. */
- return 1;
+ /* Loop through the array constructor's elements. */
+ for (c = gfc_constructor_first (expr2->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ /* If this is an iterator, assume the worst. */
+ if (c->iterator)
+ return 1;
+ /* Avoid recursion in the common case. */
+ if (c->expr->expr_type == EXPR_CONSTANT)
+ continue;
+ if (gfc_check_dependency (expr1, c->expr, 1))
+ return 1;
+ }
+ return 0;
default:
return 1;
}
-/* Calculates size of the array reference using lower bound, upper bound
- and stride. */
+/* Determines overlapping for two array sections. */
-static void
-get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
+static gfc_dependency
+check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
{
- /* nNoOfEle = (u1-l1)/s1 */
-
- mpz_sub (ele, u1->value.integer, l1->value.integer);
-
- if (s1 != NULL)
- mpz_tdiv_q (ele, ele, s1->value.integer);
-}
+ gfc_expr *l_start;
+ gfc_expr *l_end;
+ gfc_expr *l_stride;
+ gfc_expr *l_lower;
+ gfc_expr *l_upper;
+ int l_dir;
+ gfc_expr *r_start;
+ gfc_expr *r_end;
+ gfc_expr *r_stride;
+ gfc_expr *r_lower;
+ gfc_expr *r_upper;
+ gfc_expr *one_expr;
+ int r_dir;
+ int stride_comparison;
+ int start_comparison;
+
+ /* If they are the same range, return without more ado. */
+ if (is_same_range (l_ar, r_ar, n))
+ return GFC_DEP_EQUAL;
-/* Returns if the ranges ((0..Y), (X1..X2)) overlap. */
+ 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_end = r_ar->end[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];
+ /* If r_end is NULL take it from array specifier. */
+ if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar->as))
+ r_end = r_ar->as->upper[n];
+
+ /* Determine whether the l_stride is positive or negative. */
+ if (!l_stride)
+ l_dir = 1;
+ else if (l_stride->expr_type == EXPR_CONSTANT
+ && l_stride->ts.type == BT_INTEGER)
+ l_dir = mpz_sgn (l_stride->value.integer);
+ else if (l_start && l_end)
+ l_dir = gfc_dep_compare_expr (l_end, l_start);
+ else
+ l_dir = -2;
+
+ /* Determine whether the r_stride is positive or negative. */
+ if (!r_stride)
+ r_dir = 1;
+ else if (r_stride->expr_type == EXPR_CONSTANT
+ && r_stride->ts.type == BT_INTEGER)
+ r_dir = mpz_sgn (r_stride->value.integer);
+ else if (r_start && r_end)
+ r_dir = gfc_dep_compare_expr (r_end, r_start);
+ else
+ r_dir = -2;
-static gfc_dependency
-get_deps (mpz_t x1, mpz_t x2, mpz_t y)
-{
- int start;
- int end;
+ /* The strides should never be zero. */
+ if (l_dir == 0 || r_dir == 0)
+ return GFC_DEP_OVERLAP;
- start = mpz_cmp_ui (x1, 0);
- end = mpz_cmp (x2, y);
-
- /* Both ranges the same. */
- if (start == 0 && end == 0)
- return GFC_DEP_EQUAL;
+ /* Determine the relationship between the strides. Set stride_comparison to
+ -2 if the dependency cannot be determined
+ -1 if l_stride < r_stride
+ 0 if l_stride == r_stride
+ 1 if l_stride > r_stride
+ as determined by gfc_dep_compare_expr. */
- /* Distinct ranges. */
- if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
- || (mpz_cmp (x1, y) > 0 && end > 0))
- return GFC_DEP_NODEP;
+ one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
- /* Overlapping, but with corresponding elements of the second range
- greater than the first. */
- if (start > 0 && end > 0)
- return GFC_DEP_FORWARD;
+ stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
+ r_stride ? r_stride : one_expr);
- /* Overlapping in some other way. */
- return GFC_DEP_OVERLAP;
-}
+ if (l_start && r_start)
+ start_comparison = gfc_dep_compare_expr (l_start, r_start);
+ else
+ start_comparison = -2;
+
+ free (one_expr);
+ /* Determine LHS upper and lower bounds. */
+ if (l_dir == 1)
+ {
+ l_lower = l_start;
+ l_upper = l_end;
+ }
+ else if (l_dir == -1)
+ {
+ l_lower = l_end;
+ l_upper = l_start;
+ }
+ else
+ {
+ l_lower = NULL;
+ l_upper = NULL;
+ }
-/* 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) */
+ /* Determine RHS upper and lower bounds. */
+ if (r_dir == 1)
+ {
+ r_lower = r_start;
+ r_upper = r_end;
+ }
+ else if (r_dir == -1)
+ {
+ r_lower = r_end;
+ r_upper = r_start;
+ }
+ else
+ {
+ r_lower = NULL;
+ r_upper = NULL;
+ }
-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;
+ /* Check whether the ranges are disjoint. */
+ if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
+ return GFC_DEP_NODEP;
+ if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
+ return GFC_DEP_NODEP;
- /* 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. */
+ /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
+ if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
+ {
+ if (l_dir == 1 && r_dir == -1)
+ return GFC_DEP_EQUAL;
+ if (l_dir == -1 && r_dir == 1)
+ return GFC_DEP_EQUAL;
+ }
- 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)))
+ /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
+ if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
{
- return 1;
+ if (l_dir == 1 && r_dir == -1)
+ return GFC_DEP_EQUAL;
+ if (l_dir == -1 && r_dir == 1)
+ return GFC_DEP_EQUAL;
}
+ /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
+ There is no dependency if the remainder of
+ (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.
+ */
- get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
+#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
+ && (a)->ts.type == BT_INTEGER)
- 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 (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
+ && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
+ {
+ mpz_t gcd, tmp;
+ int result;
- if (l_stride != NULL)
- mpz_cdiv_q (X2, X2, r_stride->value.integer);
- mpz_add (X2, X2, X1);
+ mpz_init (gcd);
+ mpz_init (tmp);
- return 0;
-}
-
+ mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
+ mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
-/* Determines overlapping for two array sections. */
+ mpz_fdiv_r (tmp, tmp, gcd);
+ result = mpz_cmp_si (tmp, 0L);
-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;
+ mpz_clear (gcd);
+ mpz_clear (tmp);
- gfc_expr *r_start;
- gfc_expr *r_stride;
+ if (result != 0)
+ return GFC_DEP_NODEP;
+ }
- gfc_array_ref l_ar;
- gfc_array_ref r_ar;
+#undef IS_CONSTANT_INTEGER
- mpz_t no_of_elements;
- mpz_t X1, X2;
- gfc_dependency dep;
+ /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
- l_ar = lref->u.ar;
- r_ar = rref->u.ar;
+ if (l_dir == 1 && r_dir == 1 &&
+ (start_comparison == 0 || start_comparison == -1)
+ && (stride_comparison == 0 || stride_comparison == -1))
+ return GFC_DEP_FORWARD;
+
+ /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
+ x:y:-1 vs. x:y:-2. */
+ if (l_dir == -1 && r_dir == -1 &&
+ (start_comparison == 0 || start_comparison == 1)
+ && (stride_comparison == 0 || stride_comparison == 1))
+ return GFC_DEP_FORWARD;
- 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 (stride_comparison == 0 || stride_comparison == -1)
+ {
+ if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+ {
- /* 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];
+ /* Check for a(low:y:s) vs. a(z:x:s) or
+ a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
+ of low, which is always at least a forward dependence. */
- /* 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_dir == 1
+ && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
+ return GFC_DEP_FORWARD;
+ }
+ }
- /* 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];
+ if (stride_comparison == 0 || stride_comparison == 1)
+ {
+ if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
+ {
+
+ /* Check for a(high:y:-s) vs. a(z:x:-s) or
+ a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
+ of high, which is always at least a forward dependence. */
+
+ if (r_dir == -1
+ && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
+ return GFC_DEP_FORWARD;
+ }
+ }
- 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);
+ if (stride_comparison == 0)
+ {
+ /* From here, check for backwards dependencies. */
+ /* x+1:y vs. x:z. */
+ if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
+ return GFC_DEP_BACKWARD;
+
+ /* x-1:y:-1 vs. x:z:-1. */
+ if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
+ return GFC_DEP_BACKWARD;
+ }
- mpz_clear (no_of_elements);
- mpz_clear (X1);
- mpz_clear (X2);
- return dep;
+ return GFC_DEP_OVERLAP;
}
-/* 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. */
+/* Determines overlapping for a single element and a section. */
static gfc_dependency
-gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
+gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
{
- int l;
- int r;
+ gfc_array_ref *ref;
+ gfc_expr *elem;
+ gfc_expr *start;
+ gfc_expr *end;
+ gfc_expr *stride;
int s;
- s = gfc_dep_compare_expr (left, right);
- if (s == -2)
+ elem = lref->u.ar.start[n];
+ if (!elem)
return GFC_DEP_OVERLAP;
- l = gfc_dep_compare_expr (chk, left);
- r = gfc_dep_compare_expr (chk, right);
+ 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;
- /* Check for indeterminate relationships. */
- if (l == -2 || r == -2 || s == -2)
+ /* Stride should never be zero. */
+ if (s == 0)
return GFC_DEP_OVERLAP;
+ /* Positive strides. */
if (s == 1)
{
- /* When left>right we want to check for right <= chk <= left. */
- if (l <= 0 || r >= 0)
- return GFC_DEP_OVERLAP;
+ /* 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
{
- /* Otherwise check for left <= chk <= right. */
- if (l >= 0 || r <= 0)
+ 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_NODEP;
+
+ return GFC_DEP_OVERLAP;
}
-/* Determines overlapping for a single element and a section. */
+/* Traverse expr, checking all EXPR_VARIABLE symbols for their
+ forall_index attribute. Return true if any variable may be
+ being used as a FORALL index. Its safe to pessimistically
+ return true, and assume a dependency. */
+
+static bool
+contains_forall_index_p (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg;
+ gfc_constructor *c;
+ gfc_ref *ref;
+ int i;
+
+ if (!expr)
+ return false;
+
+ switch (expr->expr_type)
+ {
+ case EXPR_VARIABLE:
+ if (expr->symtree->n.sym->forall_index)
+ return true;
+ break;
+
+ case EXPR_OP:
+ if (contains_forall_index_p (expr->value.op.op1)
+ || contains_forall_index_p (expr->value.op.op2))
+ return true;
+ break;
+
+ case EXPR_FUNCTION:
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ if (contains_forall_index_p (arg->expr))
+ return true;
+ break;
+
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_SUBSTRING:
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; gfc_constructor_next (c))
+ if (contains_forall_index_p (c->expr))
+ return true;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ if (contains_forall_index_p (ref->u.ar.start[i])
+ || contains_forall_index_p (ref->u.ar.end[i])
+ || contains_forall_index_p (ref->u.ar.stride[i]))
+ return true;
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ case REF_SUBSTRING:
+ if (contains_forall_index_p (ref->u.ss.start)
+ || contains_forall_index_p (ref->u.ss.end))
+ return true;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ return false;
+}
+
+/* Determines overlapping for two single element array references. */
static gfc_dependency
-gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
+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_expr *r_end;
+ int i;
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)
+ i = gfc_dep_compare_expr (r_start, l_start);
+ if (i == 0)
+ return GFC_DEP_EQUAL;
+
+ /* Treat two scalar variables as potentially equal. This allows
+ us to prove that a(i,:) and a(j,:) have no dependency. See
+ Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
+ Proceedings of the International Conference on Parallel and
+ Distributed Processing Techniques and Applications (PDPTA2001),
+ Las Vegas, Nevada, June 2001. */
+ /* However, we need to be careful when either scalar expression
+ contains a FORALL index, as these can potentially change value
+ during the scalarization/traversal of this array reference. */
+ if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
return GFC_DEP_OVERLAP;
- return gfc_is_inside_range (l_start, r_end, r_start);
+ if (i > -2)
+ return GFC_DEP_NODEP;
+ return GFC_DEP_EQUAL;
}
-/* Determines overlapping for two single element array references. */
+/* Determine if an array ref, usually an array section specifies the
+ entire array. In addition, if the second, pointer argument is
+ provided, the function will return true if the reference is
+ contiguous; eg. (:, 1) gives true but (1,:) gives false. */
-static gfc_dependency
-gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
+bool
+gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
{
- gfc_array_ref l_ar;
- gfc_array_ref r_ar;
- gfc_expr *l_start;
- gfc_expr *r_start;
- gfc_dependency nIsDep;
+ int i;
+ int n;
+ bool lbound_OK = true;
+ bool ubound_OK = true;
- if (lref->type == REF_ARRAY && rref->type == REF_ARRAY)
+ if (contiguous)
+ *contiguous = false;
+
+ if (ref->type != REF_ARRAY)
+ return false;
+
+ if (ref->u.ar.type == AR_FULL)
{
- 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;
+ if (contiguous)
+ *contiguous = true;
+ return true;
+ }
+
+ if (ref->u.ar.type != AR_SECTION)
+ return false;
+ if (ref->next)
+ return false;
+
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ /* If we have a single element in the reference, for the reference
+ to be full, we need to ascertain that the array has a single
+ element in this dimension and that we actually reference the
+ correct element. */
+ if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+ {
+ /* This is unconditionally a contiguous reference if all the
+ remaining dimensions are elements. */
+ if (contiguous)
+ {
+ *contiguous = true;
+ for (n = i + 1; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+ *contiguous = false;
+ }
+
+ if (!ref->u.ar.as
+ || !ref->u.ar.as->lower[i]
+ || !ref->u.ar.as->upper[i]
+ || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
+ ref->u.ar.as->upper[i])
+ || !ref->u.ar.start[i]
+ || gfc_dep_compare_expr (ref->u.ar.start[i],
+ ref->u.ar.as->lower[i]))
+ return false;
+ else
+ continue;
+ }
+
+ /* Check the lower bound. */
+ if (ref->u.ar.start[i]
+ && (!ref->u.ar.as
+ || !ref->u.ar.as->lower[i]
+ || gfc_dep_compare_expr (ref->u.ar.start[i],
+ ref->u.ar.as->lower[i])))
+ lbound_OK = false;
+ /* Check the upper bound. */
+ if (ref->u.ar.end[i]
+ && (!ref->u.ar.as
+ || !ref->u.ar.as->upper[i]
+ || gfc_dep_compare_expr (ref->u.ar.end[i],
+ ref->u.ar.as->upper[i])))
+ ubound_OK = false;
+ /* Check the stride. */
+ if (ref->u.ar.stride[i]
+ && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+ return false;
+
+ /* This is unconditionally a contiguous reference as long as all
+ the subsequent dimensions are elements. */
+ if (contiguous)
+ {
+ *contiguous = true;
+ for (n = i + 1; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+ *contiguous = false;
+ }
+
+ if (!lbound_OK || !ubound_OK)
+ return false;
+ }
+ return true;
+}
+
+
+/* Determine if a full array is the same as an array section with one
+ variable limit. For this to be so, the strides must both be unity
+ and one of either start == lower or end == upper must be true. */
+
+static bool
+ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
+{
+ int i;
+ bool upper_or_lower;
+
+ if (full_ref->type != REF_ARRAY)
+ return false;
+ if (full_ref->u.ar.type != AR_FULL)
+ return false;
+ if (ref->type != REF_ARRAY)
+ return false;
+ if (ref->u.ar.type != AR_SECTION)
+ return false;
+
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ /* If we have a single element in the reference, we need to check
+ that the array has a single element and that we actually reference
+ the correct element. */
+ if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
+ {
+ if (!full_ref->u.ar.as
+ || !full_ref->u.ar.as->lower[i]
+ || !full_ref->u.ar.as->upper[i]
+ || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
+ full_ref->u.ar.as->upper[i])
+ || !ref->u.ar.start[i]
+ || gfc_dep_compare_expr (ref->u.ar.start[i],
+ full_ref->u.ar.as->lower[i]))
+ return false;
+ }
- return nIsDep;
+ /* Check the strides. */
+ if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
+ return false;
+ if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
+ return false;
+
+ upper_or_lower = false;
+ /* Check the lower bound. */
+ if (ref->u.ar.start[i]
+ && (ref->u.ar.as
+ && full_ref->u.ar.as->lower[i]
+ && gfc_dep_compare_expr (ref->u.ar.start[i],
+ full_ref->u.ar.as->lower[i]) == 0))
+ upper_or_lower = true;
+ /* Check the upper bound. */
+ if (ref->u.ar.end[i]
+ && (ref->u.ar.as
+ && full_ref->u.ar.as->upper[i]
+ && gfc_dep_compare_expr (ref->u.ar.end[i],
+ full_ref->u.ar.as->upper[i]) == 0))
+ upper_or_lower = true;
+ if (!upper_or_lower)
+ return false;
+ }
+ return true;
}
/* Finds if two array references are overlapping or not.
Return value
+ 2 : array references are overlapping but reversal of one or
+ more dimensions will clear the dependency.
1 : array references are overlapping.
- 0 : array references are not overlapping. */
+ 0 : array references are identical or not overlapping. */
int
-gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
+gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
{
int n;
gfc_dependency fin_dep;
gfc_dependency this_dep;
-
+ this_dep = GFC_DEP_ERROR;
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
+ the same type. We traverse the reference chain until we find ranges
that are not equal. */
- assert (lref->type == rref->type);
+ gcc_assert (lref->type == rref->type);
switch (lref->type)
{
case REF_COMPONENT:
break;
case REF_SUBSTRING:
- /* Substring overlaps are handled by the string assignment code. */
- return 0;
+ /* Substring overlaps are handled by the string assignment code
+ if there is not an underlying dependency. */
+ return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
case REF_ARRAY:
-
+
+ if (ref_same_as_full_array (lref, rref))
+ return 0;
+
+ if (ref_same_as_full_array (rref, lref))
+ return 0;
+
+ if (lref->u.ar.dimen != rref->u.ar.dimen)
+ {
+ if (lref->u.ar.type == AR_FULL)
+ fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
+ : GFC_DEP_OVERLAP;
+ else if (rref->u.ar.type == AR_FULL)
+ fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
+ : GFC_DEP_OVERLAP;
+ else
+ return 1;
+ break;
+ }
+
for (n=0; n < lref->u.ar.dimen; n++)
{
/* Assume dependency when either of array reference is vector
- subscript. */
+ 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);
+ this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, 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);
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);
+ gcc_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 (this_dep == GFC_DEP_NODEP)
return 0;
+ /* Now deal with the loop reversal logic: This only works on
+ ranges and is activated by setting
+ reverse[n] == GFC_ENABLE_REVERSE
+ The ability to reverse or not is set by previous conditions
+ in this dimension. If reversal is not activated, the
+ value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
+ if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
+ && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
+ {
+ /* Set reverse if backward dependence and not inhibited. */
+ if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+ reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
+ GFC_REVERSE_SET : reverse[n];
+
+ /* Set forward if forward dependence and not inhibited. */
+ if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
+ reverse[n] = (this_dep == GFC_DEP_FORWARD) ?
+ GFC_FORWARD_SET : reverse[n];
+
+ /* Flag up overlap if dependence not compatible with
+ the overall state of the expression. */
+ if (reverse && reverse[n] == GFC_REVERSE_SET
+ && this_dep == GFC_DEP_FORWARD)
+ {
+ reverse[n] = GFC_INHIBIT_REVERSE;
+ this_dep = GFC_DEP_OVERLAP;
+ }
+ else if (reverse && reverse[n] == GFC_FORWARD_SET
+ && this_dep == GFC_DEP_BACKWARD)
+ {
+ reverse[n] = GFC_INHIBIT_REVERSE;
+ this_dep = GFC_DEP_OVERLAP;
+ }
+
+ /* If no intention of reversing or reversing is explicitly
+ inhibited, convert backward dependence to overlap. */
+ if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
+ || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
+ this_dep = GFC_DEP_OVERLAP;
+ }
+
/* Overlap codes are in order of priority. We only need to
- know the worst one.*/
+ know the worst one.*/
if (this_dep > fin_dep)
fin_dep = this_dep;
}
+
+ /* If this is an equal element, we have to keep going until we find
+ the "real" array reference. */
+ if (lref->u.ar.type == AR_ELEMENT
+ && rref->u.ar.type == AR_ELEMENT
+ && fin_dep == GFC_DEP_EQUAL)
+ break;
+
/* Exactly matching and forward overlapping ranges don't cause a
dependency. */
- if (fin_dep < GFC_DEP_OVERLAP)
+ if (fin_dep < GFC_DEP_BACKWARD)
return 0;
/* Keep checking. We only have a dependency if
break;
default:
- abort();
+ gcc_unreachable ();
}
lref = lref->next;
rref = rref->next;
}
/* If we haven't seen any array refs then something went wrong. */
- assert (fin_dep != GFC_DEP_ERROR);
+ gcc_assert (fin_dep != GFC_DEP_ERROR);
- if (fin_dep < GFC_DEP_OVERLAP)
- return 0;
- else
+ /* Assume the worst if we nest to different depths. */
+ if (lref || rref)
return 1;
-}
+ return fin_dep == GFC_DEP_OVERLAP;
+}