/* Dependency analysis
- Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
{
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_OVERLAP, /* May overlap in some other way. */
GFC_DEP_NODEP /* Distinct ranges. */
}
int i;
if (e1->expr_type == EXPR_OP
- && (e1->value.op.operator == INTRINSIC_UPLUS
- || e1->value.op.operator == INTRINSIC_PARENTHESES))
+ && (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.operator == INTRINSIC_UPLUS
- || e2->value.op.operator == INTRINSIC_PARENTHESES))
+ && (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.operator == INTRINSIC_PLUS)
+ 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
return mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P+Q vs. R+S. */
- if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
+ if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
{
int l, r;
}
/* Compare X vs. X+C. */
- if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_PLUS)
+ 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
}
/* Compare X-C vs. X. */
- if (e1->expr_type == EXPR_OP && e1->value.op.operator == INTRINSIC_MINUS)
+ 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
return -mpz_sgn (e1->value.op.op2->value.integer);
/* Compare P-Q vs. R-S. */
- if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
+ if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
{
int l, r;
}
/* Compare X vs. X-C. */
- if (e2->expr_type == EXPR_OP && e2->value.op.operator == INTRINSIC_MINUS)
+ 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
case EXPR_OP:
/* Intrinsic operators are the same if their operands are the same. */
- if (e1->value.op.operator != e2->value.op.operator)
+ if (e1->value.op.op != e2->value.op.op)
return -2;
if (e1->value.op.op2 == 0)
{
}
+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.
static int
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
- gfc_expr *expr)
+ 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:
- return (gfc_ref_needs_temporary_p (expr->ref)
- || gfc_check_dependency (var, expr, 1));
+ /* 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 && expr->inline_noncopying_intrinsic)
+ 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)
{
- expr = gfc_get_noncopying_intrinsic_argument (expr);
- return gfc_check_argument_var_dependency (var, intent, expr);
+ 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);
+ }
+ 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;
static int
gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
- gfc_expr *expr)
+ gfc_expr *expr, gfc_dep_check elemental)
{
switch (other->expr_type)
{
case EXPR_VARIABLE:
- return gfc_check_argument_var_dependency (other, intent, expr);
+ 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);
+ return gfc_check_argument_dependency (other, INTENT_IN, expr,
+ elemental);
}
return 0;
int
gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
- gfc_symbol *fnsym, gfc_actual_arglist *actual)
+ gfc_symbol *fnsym, gfc_actual_arglist *actual,
+ gfc_dep_check elemental)
{
gfc_formal_arglist *formal;
gfc_expr *expr;
&& formal->sym->attr.intent == INTENT_IN)
continue;
- if (gfc_check_argument_dependency (other, intent, expr))
+ if (gfc_check_argument_dependency (other, intent, expr, elemental))
return 1;
}
/* Return 1 if e1 and e2 are equivalenced arrays, either
- directly or indirectly; ie. equivalence (a,b) for a and b
+ 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
|| !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 = gfc_current_ns->equiv_lists; l; l = l->next)
+ for (; l; l = l->next)
{
fl1 = NULL;
fl2 = NULL;
}
+/* 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
{
gfc_actual_arglist *actual;
gfc_constructor *c;
- gfc_ref *ref;
int n;
gcc_assert (expr1->expr_type == EXPR_VARIABLE);
/* If either variable is a pointer, assume the worst. */
/* 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;
+ 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;
- if (expr2->symtree->n.sym->attr.pointer)
- return 1;
- for (ref = expr2->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
return 1;
+ }
/* Otherwise distinct symbols have no dependencies. */
return 0;
/* Determine if an array ref, usually an array section specifies the
- entire array. */
+ 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)
+gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
{
int i;
+ 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)
- return true;
+ {
+ if (contiguous)
+ *contiguous = true;
+ return true;
+ }
if (ref->u.ar.type != AR_SECTION)
return false;
if (ref->next)
the correct element. */
if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
{
+ /* This is a contiguous reference. */
+ if (contiguous)
+ *contiguous = (i + 1 == ref->u.ar.dimen);
+
if (!ref->u.ar.as
|| !ref->u.ar.as->lower[i]
|| !ref->u.ar.as->upper[i]
|| !ref->u.ar.as->lower[i]
|| gfc_dep_compare_expr (ref->u.ar.start[i],
ref->u.ar.as->lower[i])))
- return false;
+ 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])))
- return false;
+ 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 a contiguous reference. */
+ if (contiguous)
+ *contiguous = (i + 1 == ref->u.ar.dimen);
+
+ 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;
}
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)
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) ? GFC_DEP_EQUAL
- : GFC_DEP_OVERLAP;
+ 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) ? GFC_DEP_EQUAL
- : GFC_DEP_OVERLAP;
+ fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
+ : GFC_DEP_OVERLAP;
else
return 1;
break;
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)
OSDN Git Service
