diff options
author | Dan Albert <danalbert@google.com> | 2015-06-17 11:09:54 -0700 |
---|---|---|
committer | Dan Albert <danalbert@google.com> | 2015-06-17 14:15:22 -0700 |
commit | f378ebf14df0952eae870c9865bab8326aa8f137 (patch) | |
tree | 31794503eb2a8c64ea5f313b93100f1163afcffb /gcc-4.7/gcc/fortran/dependency.c | |
parent | 2c58169824949d3a597d9fa81931e001ef9b1bd0 (diff) | |
download | toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.gz toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.tar.bz2 toolchain_gcc-f378ebf14df0952eae870c9865bab8326aa8f137.zip |
Delete old versions of GCC.
Change-Id: I710f125d905290e1024cbd67f48299861790c66c
Diffstat (limited to 'gcc-4.7/gcc/fortran/dependency.c')
-rw-r--r-- | gcc-4.7/gcc/fortran/dependency.c | 1943 |
1 files changed, 0 insertions, 1943 deletions
diff --git a/gcc-4.7/gcc/fortran/dependency.c b/gcc-4.7/gcc/fortran/dependency.c deleted file mode 100644 index a2cf21d65..000000000 --- a/gcc-4.7/gcc/fortran/dependency.c +++ /dev/null @@ -1,1943 +0,0 @@ -/* Dependency analysis - 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 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 3, 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 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 "constructor.h" -#include "arith.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, /* 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. */ -} -gfc_dependency; - -/* 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) -{ - 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; -} - -/* 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) - return false; - - /* If both are NULL, the end length compares equal, because we - are looking at the same variable. This can only happen for - assumed- or deferred-length character arguments. */ - - if (r1->u.ss.end == NULL && r2->u.ss.end == NULL) - break; - - if (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. */ - -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. - REAL and COMPLEX constants are only compared for equality - or inequality; if they are unequal, -2 is returned in all cases. */ - -int -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, for INTEGER only. */ - 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, for INTEGER only. */ - 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, for INTEGER only. */ - 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, for INTEGER only. */ - 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 -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); - - /* Compare REAL and COMPLEX constants. Because of the - traps and pitfalls associated with comparing - a + 1.0 with a + 0.5, check for equality only. */ - if (e2->expr_type == EXPR_CONSTANT) - { - if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL) - { - if (mpfr_cmp (e1->value.real, e2->value.real) == 0) - return 0; - else - return -2; - } - else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX) - { - if (mpc_cmp (e1->value.complex, e2->value.complex) == 0) - return 0; - else - return -2; - } - } - - if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) - return -2; - - /* For INTEGER, all cases where e2 is not constant should have - been filtered out above. */ - gcc_assert (e2->expr_type == EXPR_CONSTANT); - - 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 (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->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; addition is handled above. */ - 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 and 0 if they are not (or if the - results are indeterminate). 'n' is the dimension to compare. */ - -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. */ - 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 || i == 0) - return 0; - } - else if (e2 && !e1) - { - i = gfc_expr_is_one (e2, -1); - if (i == -1 || i == 0) - return 0; - } - else if (e1 && e2) - { - i = gfc_dep_compare_expr (e1, e2); - 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 (ar2->as && !e2) - e2 = ar2->as->lower[n]; - - /* Check we have values for both. */ - if (!(e1 && e2)) - return 0; - - i = gfc_dep_compare_expr (e1, e2); - if (i != 0) - return 0; - } - - /* 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]; - - if (ar2->as && !e2) - e2 = ar2->as->upper[n]; - - /* 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; -} - - -/* 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 *other, sym_intent intent, - gfc_symbol *fnsym, gfc_actual_arglist *actual, - gfc_dep_check elemental) -{ - gfc_formal_arglist *formal; - gfc_expr *expr; - - 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; - } - - /* 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) - { - for (ref1 = expr1->ref; ref1; ref1 = ref1->next) - { - if (ref1->type != REF_COMPONENT) - continue; - - if (ref1->u.c.component->ts.type == BT_DERIVED) - return false; - - if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) - && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) - return false; - - seen_component_ref = true; - } - } - - 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; - - if ((sym2->attr.pointer || cm1->attr.pointer) - && gfc_compare_types (&cm1->ts, &sym2->ts)) - return false; - } - } - - 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 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, bool identical) -{ - gfc_actual_arglist *actual; - gfc_constructor *c; - int n; - - gcc_assert (expr1->expr_type == EXPR_VARIABLE); - - switch (expr2->expr_type) - { - case EXPR_OP: - n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); - if (n) - return n; - if (expr2->value.op.op2) - return gfc_check_dependency (expr1, expr2->value.op.op2, identical); - return 0; - - case EXPR_VARIABLE: - /* The interesting cases are when the symbols don't match. */ - if (expr1->symtree->n.sym != expr2->symtree->n.sym) - { - 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; - - /* 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; - } - - /* 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: - 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, identical); - if (n) - return n; - } - return 0; - - case EXPR_CONSTANT: - case EXPR_NULL: - return 0; - - case EXPR_ARRAY: - /* 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; - } -} - - -/* Determines overlapping for two array sections. */ - -static gfc_dependency -check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) -{ - 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; - - 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; - - /* The strides should never be zero. */ - if (l_dir == 0 || r_dir == 0) - return GFC_DEP_OVERLAP; - - /* 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. */ - - one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); - - stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr, - r_stride ? r_stride : one_expr); - - 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; - } - - /* 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; - } - - /* 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; - - /* 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; - } - - /* 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) - { - 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. - */ - -#define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ - && (a)->ts.type == BT_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; - - mpz_init (gcd); - mpz_init (tmp); - - mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); - mpz_sub (tmp, l_start->value.integer, r_start->value.integer); - - mpz_fdiv_r (tmp, tmp, gcd); - result = mpz_cmp_si (tmp, 0L); - - mpz_clear (gcd); - mpz_clear (tmp); - - if (result != 0) - return GFC_DEP_NODEP; - } - -#undef IS_CONSTANT_INTEGER - - /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */ - - 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; - - if (stride_comparison == 0 || stride_comparison == -1) - { - if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) - { - - /* 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 (r_dir == 1 - && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) - return GFC_DEP_FORWARD; - } - } - - 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; - } - } - - - 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; - } - - return GFC_DEP_OVERLAP; -} - - -/* 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; -} - - -/* 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_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; - int i; - - l_ar = lref->u.ar; - r_ar = rref->u.ar; - l_start = l_ar.start[n] ; - r_start = r_ar.start[n] ; - 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; - - if (i > -2) - return GFC_DEP_NODEP; - return GFC_DEP_EQUAL; -} - - -/* 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. */ - -bool -gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) -{ - int i; - int n; - bool lbound_OK = true; - bool ubound_OK = true; - - if (contiguous) - *contiguous = false; - - if (ref->type != REF_ARRAY) - return false; - - if (ref->u.ar.type == AR_FULL) - { - 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; - } - - /* 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 identical or not overlapping. */ - -int -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 until we find ranges - that are not equal. */ - gcc_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 - 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. */ - 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 = 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); - 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 - { - 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 any dimension doesn't overlap, we have no dependency. */ - 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.*/ - 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_BACKWARD) - return 0; - - /* Keep checking. We only have a dependency if - subsequent references also overlap. */ - break; - - default: - gcc_unreachable (); - } - lref = lref->next; - rref = rref->next; - } - - /* If we haven't seen any array refs then something went wrong. */ - gcc_assert (fin_dep != GFC_DEP_ERROR); - - /* Assume the worst if we nest to different depths. */ - if (lref || rref) - return 1; - - return fin_dep == GFC_DEP_OVERLAP; -} |