#include "gfortran.h"
#include "dependency.h"
#include "constructor.h"
+#include "arith.h"
/* static declarations */
/* Enums */
/* Return true for identical variables, checking for references if
necessary. Calls identical_array_ref for checking array sections. */
-bool
-gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
+static bool
+are_identical_variables (gfc_expr *e1, gfc_expr *e2)
{
gfc_ref *r1, *r2;
- if (e1->symtree->n.sym != e2->symtree->n.sym)
+ 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;
break;
default:
- gfc_internal_error ("gfc_are_identical_variables: Bad type");
+ gfc_internal_error ("are_identical_variables: Bad type");
}
r1 = r1->next;
r2 = r2->next;
return true;
}
-/* 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. */
+/* 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. */
int
gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
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)
+ if (l == 0 && r > -2)
return r;
- if (l != -2 && r == 0)
+ if (l > -2 && r == 0)
return l;
if (l == 1 && r == 1)
return 1;
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)
+ if (l == 0 && r > -2)
return r;
- if (l != -2 && r == 0)
+ if (l > -2 && r == 0)
return l;
if (l == 1 && r == 1)
return 1;
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)
+ if (l > -2 && r == 0)
return l;
- if (l == 0 && r != -2)
+ if (l == 0 && r > -2)
return -r;
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 (e1->expr_type != e2->expr_type)
- return -2;
+ return -3;
switch (e1->expr_type)
{
case EXPR_CONSTANT:
+ /* Compare strings for equality. */
+ if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
+ return gfc_compare_string (e1, e2);
+
if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
return -2;
return 1;
case EXPR_VARIABLE:
- if (gfc_are_identical_variables (e1, e2))
+ if (are_identical_variables (e1, e2))
return 0;
else
- return -2;
+ return -3;
case EXPR_OP:
/* Intrinsic operators are the same if their operands are the same. */
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;
- /* TODO Handle commutative binary operators here? */
+ 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:
- /* We can only compare calls to the same intrinsic function. */
- if (e1->value.function.isym == 0 || e2->value.function.isym == 0
- || e1->value.function.isym != e2->value.function.isym)
- return -2;
-
- args1 = e1->value.function.actual;
- args2 = e2->value.function.actual;
-
- /* We should list the "constant" intrinsic functions. Those
- without side-effects that provide equal results given equal
- argument lists. */
- switch (e1->value.function.isym->id)
- {
-
- case GFC_ISYM_REAL:
- case GFC_ISYM_LOGICAL:
- case GFC_ISYM_DBLE:
- break;
-
- default:
- return -2;
- }
+ return gfc_dep_compare_functions (e1, e2, false);
+ break;
- /* Compare the argument lists for equality. */
- while (args1 && args2)
- {
- if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
- return -2;
- args1 = args1->next;
- args2 = args2->next;
- }
- return (args1 || args2) ? -2 : 0;
-
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;
if (e1 && !e2)
{
i = gfc_expr_is_one (e1, -1);
- if (i == -1)
- return def;
- else if (i == 0)
+ if (i == -1 || i == 0)
return 0;
}
else if (e2 && !e1)
{
i = gfc_expr_is_one (e2, -1);
- if (i == -1)
- return def;
- else if (i == 0)
+ if (i == -1 || i == 0)
return 0;
}
else if (e1 && e2)
{
i = gfc_dep_compare_expr (e1, e2);
- if (i == -2)
- return def;
- else if (i != 0)
+ if (i != 0)
return 0;
}
/* The strides match. */
/* Check we have values for both. */
if (!(e1 && e2))
- return def;
+ return 0;
i = gfc_dep_compare_expr (e1, e2);
- if (i == -2)
- return def;
- else if (i != 0)
+ if (i != 0)
return 0;
}
/* Check we have values for both. */
if (!(e1 && e2))
- return def;
+ return 0;
i = gfc_dep_compare_expr (e1, e2);
- if (i == -2)
- return def;
- else if (i != 0)
+ if (i != 0)
return 0;
}
return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
- if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
- && (arg = gfc_get_noncopying_intrinsic_argument (expr))
- && gfc_check_argument_var_dependency (var, intent, arg, elemental))
- return 1;
- if (elemental)
+ 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)
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;
return gfc_check_argument_var_dependency (other, intent, expr, elemental);
case EXPR_FUNCTION:
- if (other->inline_noncopying_intrinsic)
- {
- other = gfc_get_noncopying_intrinsic_argument (other);
- return gfc_check_argument_dependency (other, INTENT_IN, expr,
- elemental);
- }
+ 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 1;
case EXPR_FUNCTION:
- if (expr2->inline_noncopying_intrinsic)
+ 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. */
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 (gfc_is_same_range (l_ar, r_ar, n, 0))
+ if (is_same_range (l_ar, r_ar, n))
return GFC_DEP_EQUAL;
l_start = l_ar->start[n];
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)
{
#undef IS_CONSTANT_INTEGER
- /* Check for forward dependencies x:y vs. x+1:z. */
- if (l_dir == 1 && r_dir == 1
- && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
- && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
+ /* 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)
{
- /* Check that the strides are the same. */
- if (!l_stride && !r_stride)
- return GFC_DEP_FORWARD;
- if (l_stride && r_stride
- && gfc_dep_compare_expr (l_stride, r_stride) == 0)
- return GFC_DEP_FORWARD;
+ 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;
+ }
}
- /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
- if (l_dir == -1 && r_dir == -1
- && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
- && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
+ if (stride_comparison == 0 || stride_comparison == 1)
{
- /* Check that the strides are the same. */
- if (!l_stride && !r_stride)
- return GFC_DEP_FORWARD;
- if (l_stride && r_stride
- && gfc_dep_compare_expr (l_stride, r_stride) == 0)
- return GFC_DEP_FORWARD;
+ 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;
+ }
}
- /* Check for backward dependencies:
- Are the strides the same?. */
- if ((!l_stride && !r_stride)
- ||
- (l_stride && r_stride
- && gfc_dep_compare_expr (l_stride, r_stride) == 0))
+
+ if (stride_comparison == 0)
{
- /* x:y vs. x+1:z. */
- if (l_dir == 1 && r_dir == 1
- && l_start && r_start
- && gfc_dep_compare_expr (l_start, r_start) == 1
- && l_end && r_end
- && gfc_dep_compare_expr (l_end, r_end) == 1)
+ /* 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:y:-1 vs. x-1:z:-1. */
- if (l_dir == -1 && r_dir == -1
- && l_start && r_start
- && gfc_dep_compare_expr (l_start, r_start) == -1
- && l_end && r_end
- && gfc_dep_compare_expr (l_end, r_end) == -1)
+ /* x-1:y:-1 vs. x:z:-1. */
+ if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
return GFC_DEP_BACKWARD;
}
if (!start || !end)
return GFC_DEP_OVERLAP;
s = gfc_dep_compare_expr (start, end);
- if (s == -2)
+ if (s <= -2)
return GFC_DEP_OVERLAP;
/* Assume positive stride. */
if (s == -1)
if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
return GFC_DEP_OVERLAP;
- if (i != -2)
+ if (i > -2)
return GFC_DEP_NODEP;
return GFC_DEP_EQUAL;
}
/* Now deal with the loop reversal logic: This only works on
ranges and is activated by setting
- reverse[n] == GFC_CAN_REVERSE
+ 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. */
&& lref->u.ar.dimen_type[n] == DIMEN_RANGE)
{
/* Set reverse if backward dependence and not inhibited. */
- if (reverse && reverse[n] != GFC_CANNOT_REVERSE)
+ if (reverse && reverse[n] == GFC_ENABLE_REVERSE)
reverse[n] = (this_dep == GFC_DEP_BACKWARD) ?
GFC_REVERSE_SET : reverse[n];
- /* Inhibit loop reversal if dependence not compatible. */
- if (reverse && reverse[n] != GFC_REVERSE_NOT_SET
- && this_dep != GFC_DEP_EQUAL
- && this_dep != GFC_DEP_BACKWARD
- && this_dep != GFC_DEP_NODEP)
+ /* 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_CANNOT_REVERSE;
- if (this_dep != GFC_DEP_FORWARD)
- this_dep = GFC_DEP_OVERLAP;
+ 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 (this_dep == GFC_DEP_BACKWARD
- && (reverse == NULL || reverse[n] == GFC_CANNOT_REVERSE))
+ if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
+ || (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE))
this_dep = GFC_DEP_OVERLAP;
}
OSDN Git Service
