/* Dependency analysis
- Copyright (C) 2000-2014 Free Software Foundation, Inc.
+ Copyright (C) 2000-2020 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
This file is part of GCC.
enum range {LHS, RHS, MID};
/* Dependency types. These must be in reverse order of priority. */
-typedef enum
+enum gfc_dependency
{
GFC_DEP_ERROR,
GFC_DEP_EQUAL, /* Identical Ranges. */
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))
if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
{
- gcc_assert (a1->dimen == a2->dimen);
+ if (a1->dimen != a2->dimen)
+ gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
+
for (i = 0; i < a1->dimen; i++)
{
if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
break;
+ case REF_INQUIRY:
+ if (r1->u.i != r2->u.i)
+ return false;
+ break;
+
default:
gfc_internal_error ("are_identical_variables: Bad type");
}
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;
+ if (args1->expr != NULL && args2->expr != NULL)
+ {
+ gfc_expr *e1, *e2;
+ e1 = args1->expr;
+ e2 = args2->expr;
+
+ if (gfc_dep_compare_expr (e1, e2) != 0)
+ return -2;
+
+ /* Special case: String arguments which compare equal can have
+ different lengths, which makes them different in calls to
+ procedures. */
+
+ if (e1->expr_type == EXPR_CONSTANT
+ && e1->ts.type == BT_CHARACTER
+ && e2->expr_type == EXPR_CONSTANT
+ && e2->ts.type == BT_CHARACTER
+ && e1->value.character.length != e2->value.character.length)
+ return -2;
+ }
args1 = args1->next;
args2 = args2->next;
/* Helper function to look through parens, unary plus and widening
integer conversions. */
-static gfc_expr*
-discard_nops (gfc_expr *e)
+gfc_expr *
+gfc_discard_nops (gfc_expr *e)
{
gfc_actual_arglist *arglist;
if (e1 == NULL && e2 == NULL)
return 0;
+ else if (e1 == NULL || e2 == NULL)
+ return -2;
- e1 = discard_nops (e1);
- e2 = discard_nops (e2);
+ e1 = gfc_discard_nops (e1);
+ e2 = gfc_discard_nops (e2);
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
case EXPR_FUNCTION:
return gfc_dep_compare_functions (e1, e2, false);
- break;
default:
return -2;
if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
return false;
- e1 = discard_nops (e1);
- e2 = discard_nops (e2);
+ e1 = gfc_discard_nops (e1);
+ e2 = gfc_discard_nops (e2);
/* Inizialize tentatively, clear if we don't return anything. */
mpz_init (*result);
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
{
- e1_op1 = discard_nops (e1->value.op.op1);
- e1_op2 = discard_nops (e1->value.op.op2);
+ e1_op1 = gfc_discard_nops (e1->value.op.op1);
+ e1_op2 = gfc_discard_nops (e1->value.op.op2);
/* Case 2: (X + c1) - X = c1. */
if (e1_op2->expr_type == EXPR_CONSTANT
return true;
}
- /* Case 3: (c1 + X) - X = c1. */
+ /* Case 3: (c1 + X) - X = c1. */
if (e1_op1->expr_type == EXPR_CONSTANT
&& gfc_dep_compare_expr (e1_op2, e2) == 0)
{
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
{
- e1_op1 = discard_nops (e1->value.op.op1);
- e1_op2 = discard_nops (e1->value.op.op2);
+ e1_op1 = gfc_discard_nops (e1->value.op.op1);
+ e1_op2 = gfc_discard_nops (e1->value.op.op2);
if (e1_op2->expr_type == EXPR_CONSTANT)
{
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
if (e2_op2->expr_type == EXPR_CONSTANT
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 13: (X - c1) - (X - c2) = c2 - c1. */
if (e2_op2->expr_type == EXPR_CONSTANT
{
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 15: X - (X + c2) = -c2. */
if (e2_op2->expr_type == EXPR_CONSTANT
if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
- e2_op1 = discard_nops (e2->value.op.op1);
- e2_op2 = discard_nops (e2->value.op.op2);
+ e2_op1 = gfc_discard_nops (e2->value.op.op1);
+ e2_op2 = gfc_discard_nops (e2->value.op.op2);
/* Case 17: X - (X - c2) = c2. */
if (e2_op2->expr_type == EXPR_CONSTANT
return subarray_p;
case REF_COMPONENT:
+ case REF_INQUIRY:
break;
}
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);
+
+ if (var->expr_type == EXPR_VARIABLE
+ && expr->expr_type == EXPR_VARIABLE
+ && strcmp(var->symtree->name, expr->symtree->name) == 0)
+ gfc_warning (0, "INTENT(%s) actual argument at %L might "
+ "interfere with actual argument at %L.",
+ intent == INTENT_OUT ? "OUT" : "INOUT",
+ &var->where, &expr->where);
}
return 0;
}
gfc_constructor *c;
int n;
- gcc_assert (expr1->expr_type == EXPR_VARIABLE);
+ /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
+ and a reference to _F.caf_get, so skip the assert. */
+ if (expr1->expr_type == EXPR_FUNCTION
+ && strcmp (expr1->value.function.name, "_F.caf_get") == 0)
+ return 0;
+
+ if (expr1->expr_type != EXPR_VARIABLE)
+ gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
switch (expr2->expr_type)
{
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 gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
return 1;
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))
+ if (l_start == NULL && 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))
+ if (l_end == NULL && 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))
+ if (r_start == NULL && 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))
+ if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
r_end = r_ar->as->upper[n];
/* Determine whether the l_stride is positive or negative. */
#undef IS_CONSTANT_INTEGER
- /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+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)
if (i > -2)
return GFC_DEP_NODEP;
+
return GFC_DEP_EQUAL;
}
+/* Callback function for checking if an expression depends on a
+ dummy variable which is any other than INTENT(IN). */
+
+static int
+callback_dummy_intent_not_in (gfc_expr **ep,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *e = *ep;
+
+ if (e->expr_type == EXPR_VARIABLE && e->symtree
+ && e->symtree->n.sym->attr.dummy)
+ return e->symtree->n.sym->attr.intent != INTENT_IN;
+ else
+ return 0;
+}
+
+/* Auxiliary function to check if subexpressions have dummy variables which
+ are not intent(in).
+*/
+
+static bool
+dummy_intent_not_in (gfc_expr **ep)
+{
+ return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
+}
/* 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. */
+ contiguous; eg. (:, 1) gives true but (1,:) gives false.
+ If one of the bounds depends on a dummy variable which is
+ not INTENT(IN), also return false, because the user may
+ have changed the variable. */
bool
gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
&& (!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])))
+ ref->u.ar.as->lower[i])
+ || dummy_intent_not_in (&ref->u.ar.start[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])))
+ ref->u.ar.as->upper[i])
+ || dummy_intent_not_in (&ref->u.ar.end[i])))
ubound_OK = false;
/* Check the stride. */
if (ref->u.ar.stride[i]
/* Finds if two array references are overlapping or not.
Return value
- 2 : array references are overlapping but reversal of one or
+ 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. */
+ 1 : array references are overlapping, or identical is true and
+ there is some kind of overlap.
+ 0 : array references are identical or not overlapping. */
int
-gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
+gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
+ bool identical)
{
int n;
int m;
gfc_dependency fin_dep;
gfc_dependency this_dep;
+ bool same_component = false;
this_dep = GFC_DEP_ERROR;
fin_dep = GFC_DEP_ERROR;
while (lref && rref)
{
+ /* The refs might come in mixed, one with a _data component and one
+ without. Look at their next reference in order to avoid an
+ ICE. */
+
+ if (lref && lref->type == REF_COMPONENT && lref->u.c.component
+ && strcmp (lref->u.c.component->name, "_data") == 0)
+ lref = lref->next;
+
+ if (rref && rref->type == REF_COMPONENT && rref->u.c.component
+ && strcmp (rref->u.c.component->name, "_data") == 0)
+ rref = rref->next;
+
/* 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. */
components. */
if (lref->u.c.component != rref->u.c.component)
return 0;
+
+ same_component = true;
break;
case REF_SUBSTRING:
case REF_ARRAY:
+ /* For now, treat all coarrays as dangerous. */
+ if (lref->u.ar.codimen || rref->u.ar.codimen)
+ return 1;
+
if (ref_same_as_full_array (lref, rref))
- return 0;
+ return identical;
if (ref_same_as_full_array (rref, lref))
- return 0;
+ return identical;
if (lref->u.ar.dimen != rref->u.ar.dimen)
{
/* Index for the reverse array. */
m = -1;
- for (n=0; n < lref->u.ar.dimen; n++)
+ for (n = 0; n < lref->u.ar.dimen; n++)
{
/* Handle dependency when either of array reference is vector
subscript. There is no dependency if the vector indices
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);
+ 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);
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 (identical && this_dep == GFC_DEP_EQUAL)
+ this_dep = GFC_DEP_OVERLAP;
}
/* If any dimension doesn't overlap, we have no dependency. */
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[m] == GFC_ENABLE_REVERSE)
- reverse[m] = (this_dep == GFC_DEP_BACKWARD) ?
- GFC_REVERSE_SET : reverse[m];
-
- /* Set forward if forward dependence and not inhibited. */
- if (reverse && reverse[m] == GFC_ENABLE_REVERSE)
- reverse[m] = (this_dep == GFC_DEP_FORWARD) ?
- GFC_FORWARD_SET : reverse[m];
-
- /* Flag up overlap if dependence not compatible with
- the overall state of the expression. */
- if (reverse && reverse[m] == GFC_REVERSE_SET
- && this_dep == GFC_DEP_FORWARD)
+ if (reverse)
{
- reverse[m] = GFC_INHIBIT_REVERSE;
- this_dep = GFC_DEP_OVERLAP;
- }
- else if (reverse && reverse[m] == GFC_FORWARD_SET
- && this_dep == GFC_DEP_BACKWARD)
- {
- reverse[m] = GFC_INHIBIT_REVERSE;
- this_dep = GFC_DEP_OVERLAP;
+ /* Reverse if backward dependence and not inhibited. */
+ if (reverse[m] == GFC_ENABLE_REVERSE
+ && this_dep == GFC_DEP_BACKWARD)
+ reverse[m] = GFC_REVERSE_SET;
+
+ /* Forward if forward dependence and not inhibited. */
+ if (reverse[m] == GFC_ENABLE_REVERSE
+ && this_dep == GFC_DEP_FORWARD)
+ reverse[m] = GFC_FORWARD_SET;
+
+ /* Flag up overlap if dependence not compatible with
+ the overall state of the expression. */
+ if (reverse[m] == GFC_REVERSE_SET
+ && this_dep == GFC_DEP_FORWARD)
+ {
+ reverse[m] = GFC_INHIBIT_REVERSE;
+ this_dep = GFC_DEP_OVERLAP;
+ }
+ else if (reverse[m] == GFC_FORWARD_SET
+ && this_dep == GFC_DEP_BACKWARD)
+ {
+ reverse[m] = 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[m] == GFC_INHIBIT_REVERSE))
+ if ((!reverse && this_dep == GFC_DEP_BACKWARD)
+ || (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
this_dep = GFC_DEP_OVERLAP;
}
know the worst one.*/
update_fin_dep:
+ if (identical && this_dep == GFC_DEP_EQUAL)
+ this_dep = GFC_DEP_OVERLAP;
+
if (this_dep > fin_dep)
fin_dep = this_dep;
}
/* Exactly matching and forward overlapping ranges don't cause a
dependency. */
- if (fin_dep < GFC_DEP_BACKWARD)
+ if (fin_dep < GFC_DEP_BACKWARD && !identical)
return 0;
/* Keep checking. We only have a dependency if
rref = rref->next;
}
+ /* Assume the worst if we nest to different depths. */
+ if (lref || rref)
+ return 1;
+
+ /* This can result from concatenation of assumed length string components. */
+ if (same_component && fin_dep == GFC_DEP_ERROR)
+ return 1;
+
/* 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)
+ if (identical && fin_dep != GFC_DEP_NODEP)
return 1;
return fin_dep == GFC_DEP_OVERLAP;
projects / thirdparty / gcc.git / blobdiff