X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fdependency.c;h=fd7fa73442678b1e3957ff8e9ad20ec6d6752c59;hp=a89e96504da47440336d565d1c0583ab050cdc84;hb=efeb2b164fbfa123b7dee536ecab9edff0621e5d;hpb=231e961a9a50ce102e447163c26f978c313c95ee diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index a89e96504da..fd7fa734426 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -1,12 +1,13 @@ /* 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 This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +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 @@ -15,19 +16,20 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +along with GCC; see the file COPYING3. If not see +. */ /* 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 */ @@ -38,7 +40,8 @@ typedef enum { 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. */ } @@ -47,12 +50,16 @@ 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) +gfc_expr_is_one (gfc_expr *expr, int def) { gcc_assert (expr != NULL); @@ -65,21 +72,358 @@ gfc_expr_is_one (gfc_expr * expr, int 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; @@ -91,23 +435,46 @@ gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2) 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; @@ -124,25 +491,19 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def) 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. */ @@ -150,182 +511,576 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def) /* 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; - gcc_assert (dest->expr_type == EXPR_VARIABLE - && fncall->expr_type == EXPR_FUNCTION); - gcc_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; - } - gcc_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; gcc_assert (expr1->expr_type == EXPR_VARIABLE); - /* TODO: -fassume-no-pointer-aliasing */ - if (expr1->symtree->n.sym->attr.pointer) - return 1; - for (ref = expr1->ref; ref; ref = ref->next) - { - if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) - return 1; - } - switch (expr2->expr_type) { case EXPR_OP: - n = gfc_check_dependency (expr1, expr2->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: + 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. */ + 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; @@ -333,267 +1088,670 @@ gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars, } -/* 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. */ @@ -601,7 +1759,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) 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. */ gcc_assert (lref->type == rref->type); switch (lref->type) @@ -614,21 +1772,42 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) 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); @@ -638,7 +1817,7 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) else { gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT - && lref->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); } @@ -646,14 +1825,63 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) 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 @@ -670,9 +1898,9 @@ gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) /* If we haven't seen any array refs then something went wrong. */ 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; +}