2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* dependency.c -- Expression dependency analysis code. */
23 /* There's probably quite a bit of duplication in this file. We currently
24 have different dependency checking functions for different types
25 if dependencies. Ideally these would probably be merged. */
30 #include "dependency.h"
31 #include "constructor.h"
33 /* static declarations */
35 enum range {LHS, RHS, MID};
37 /* Dependency types. These must be in reverse order of priority. */
41 GFC_DEP_EQUAL, /* Identical Ranges. */
42 GFC_DEP_FORWARD, /* e.g., a(1:3), a(2:4). */
43 GFC_DEP_OVERLAP, /* May overlap in some other way. */
44 GFC_DEP_NODEP /* Distinct ranges. */
49 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
52 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
53 def if the value could not be determined. */
56 gfc_expr_is_one (gfc_expr *expr, int def)
58 gcc_assert (expr != NULL);
60 if (expr->expr_type != EXPR_CONSTANT)
63 if (expr->ts.type != BT_INTEGER)
66 return mpz_cmp_si (expr->value.integer, 1) == 0;
70 /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
71 and -2 if the relationship could not be determined. */
74 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
76 gfc_actual_arglist *args1;
77 gfc_actual_arglist *args2;
80 if (e1->expr_type == EXPR_OP
81 && (e1->value.op.op == INTRINSIC_UPLUS
82 || e1->value.op.op == INTRINSIC_PARENTHESES))
83 return gfc_dep_compare_expr (e1->value.op.op1, e2);
84 if (e2->expr_type == EXPR_OP
85 && (e2->value.op.op == INTRINSIC_UPLUS
86 || e2->value.op.op == INTRINSIC_PARENTHESES))
87 return gfc_dep_compare_expr (e1, e2->value.op.op1);
89 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
91 /* Compare X+C vs. X. */
92 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
93 && e1->value.op.op2->ts.type == BT_INTEGER
94 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
95 return mpz_sgn (e1->value.op.op2->value.integer);
97 /* Compare P+Q vs. R+S. */
98 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
102 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
103 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
104 if (l == 0 && r == 0)
106 if (l == 0 && r != -2)
108 if (l != -2 && r == 0)
110 if (l == 1 && r == 1)
112 if (l == -1 && r == -1)
115 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
116 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
117 if (l == 0 && r == 0)
119 if (l == 0 && r != -2)
121 if (l != -2 && r == 0)
123 if (l == 1 && r == 1)
125 if (l == -1 && r == -1)
130 /* Compare X vs. X+C. */
131 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
133 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
134 && e2->value.op.op2->ts.type == BT_INTEGER
135 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
136 return -mpz_sgn (e2->value.op.op2->value.integer);
139 /* Compare X-C vs. X. */
140 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
142 if (e1->value.op.op2->expr_type == EXPR_CONSTANT
143 && e1->value.op.op2->ts.type == BT_INTEGER
144 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
145 return -mpz_sgn (e1->value.op.op2->value.integer);
147 /* Compare P-Q vs. R-S. */
148 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
152 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
153 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
154 if (l == 0 && r == 0)
156 if (l != -2 && r == 0)
158 if (l == 0 && r != -2)
160 if (l == 1 && r == -1)
162 if (l == -1 && r == 1)
167 /* Compare X vs. X-C. */
168 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
170 if (e2->value.op.op2->expr_type == EXPR_CONSTANT
171 && e2->value.op.op2->ts.type == BT_INTEGER
172 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
173 return mpz_sgn (e2->value.op.op2->value.integer);
176 if (e1->expr_type != e2->expr_type)
179 switch (e1->expr_type)
182 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
185 i = mpz_cmp (e1->value.integer, e2->value.integer);
193 if (e1->ref || e2->ref)
195 if (e1->symtree->n.sym == e2->symtree->n.sym)
200 /* Intrinsic operators are the same if their operands are the same. */
201 if (e1->value.op.op != e2->value.op.op)
203 if (e1->value.op.op2 == 0)
205 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
206 return i == 0 ? 0 : -2;
208 if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
209 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
211 /* TODO Handle commutative binary operators here? */
215 /* We can only compare calls to the same intrinsic function. */
216 if (e1->value.function.isym == 0 || e2->value.function.isym == 0
217 || e1->value.function.isym != e2->value.function.isym)
220 args1 = e1->value.function.actual;
221 args2 = e2->value.function.actual;
223 /* We should list the "constant" intrinsic functions. Those
224 without side-effects that provide equal results given equal
226 switch (e1->value.function.isym->id)
228 case GFC_ISYM_CONVERSION:
229 /* Handle integer extensions specially, as __convert_i4_i8
230 is not only "constant" but also "unary" and "increasing". */
231 if (args1 && !args1->next
232 && args2 && !args2->next
233 && e1->ts.type == BT_INTEGER
234 && args1->expr->ts.type == BT_INTEGER
235 && e1->ts.kind > args1->expr->ts.kind
236 && e2->ts.type == e1->ts.type
237 && e2->ts.kind == e1->ts.kind
238 && args2->expr->ts.type == args1->expr->ts.type
239 && args2->expr->ts.kind == args2->expr->ts.kind)
240 return gfc_dep_compare_expr (args1->expr, args2->expr);
244 case GFC_ISYM_LOGICAL:
252 /* Compare the argument lists for equality. */
253 while (args1 && args2)
255 if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
260 return (args1 || args2) ? -2 : 0;
268 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
269 if the results are indeterminate. N is the dimension to compare. */
272 gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
278 /* TODO: More sophisticated range comparison. */
279 gcc_assert (ar1 && ar2);
281 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
285 /* Check for mismatching strides. A NULL stride means a stride of 1. */
288 i = gfc_expr_is_one (e1, -1);
296 i = gfc_expr_is_one (e2, -1);
304 i = gfc_dep_compare_expr (e1, e2);
310 /* The strides match. */
312 /* Check the range start. */
317 /* Use the bound of the array if no bound is specified. */
319 e1 = ar1->as->lower[n];
322 e2 = ar2->as->lower[n];
324 /* Check we have values for both. */
328 i = gfc_dep_compare_expr (e1, e2);
335 /* Check the range end. */
340 /* Use the bound of the array if no bound is specified. */
342 e1 = ar1->as->upper[n];
345 e2 = ar2->as->upper[n];
347 /* Check we have values for both. */
351 i = gfc_dep_compare_expr (e1, e2);
362 /* Some array-returning intrinsics can be implemented by reusing the
363 data from one of the array arguments. For example, TRANSPOSE does
364 not necessarily need to allocate new data: it can be implemented
365 by copying the original array's descriptor and simply swapping the
366 two dimension specifications.
368 If EXPR is a call to such an intrinsic, return the argument
369 whose data can be reused, otherwise return NULL. */
372 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
374 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
377 switch (expr->value.function.isym->id)
379 case GFC_ISYM_TRANSPOSE:
380 return expr->value.function.actual->expr;
388 /* Return true if the result of reference REF can only be constructed
389 using a temporary array. */
392 gfc_ref_needs_temporary_p (gfc_ref *ref)
398 for (; ref; ref = ref->next)
402 /* Vector dimensions are generally not monotonic and must be
403 handled using a temporary. */
404 if (ref->u.ar.type == AR_SECTION)
405 for (n = 0; n < ref->u.ar.dimen; n++)
406 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
413 /* Within an array reference, character substrings generally
414 need a temporary. Character array strides are expressed as
415 multiples of the element size (consistent with other array
416 types), not in characters. */
428 gfc_is_data_pointer (gfc_expr *e)
432 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
435 /* No subreference if it is a function */
436 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
438 if (e->symtree->n.sym->attr.pointer)
441 for (ref = e->ref; ref; ref = ref->next)
442 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
449 /* Return true if array variable VAR could be passed to the same function
450 as argument EXPR without interfering with EXPR. INTENT is the intent
453 This is considerably less conservative than other dependencies
454 because many function arguments will already be copied into a
458 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
459 gfc_expr *expr, gfc_dep_check elemental)
463 gcc_assert (var->expr_type == EXPR_VARIABLE);
464 gcc_assert (var->rank > 0);
466 switch (expr->expr_type)
469 /* In case of elemental subroutines, there is no dependency
470 between two same-range array references. */
471 if (gfc_ref_needs_temporary_p (expr->ref)
472 || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
474 if (elemental == ELEM_DONT_CHECK_VARIABLE)
476 /* Too many false positive with pointers. */
477 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
479 /* Elemental procedures forbid unspecified intents,
480 and we don't check dependencies for INTENT_IN args. */
481 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
483 /* We are told not to check dependencies.
484 We do it, however, and issue a warning in case we find one.
485 If a dependency is found in the case
486 elemental == ELEM_CHECK_VARIABLE, we will generate
487 a temporary, so we don't need to bother the user. */
488 gfc_warning ("INTENT(%s) actual argument at %L might "
489 "interfere with actual argument at %L.",
490 intent == INTENT_OUT ? "OUT" : "INOUT",
491 &var->where, &expr->where);
501 return gfc_check_dependency (var, expr, 1);
504 if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
505 && (arg = gfc_get_noncopying_intrinsic_argument (expr))
506 && gfc_check_argument_var_dependency (var, intent, arg, elemental))
510 if ((expr->value.function.esym
511 && expr->value.function.esym->attr.elemental)
512 || (expr->value.function.isym
513 && expr->value.function.isym->elemental))
514 return gfc_check_fncall_dependency (var, intent, NULL,
515 expr->value.function.actual,
516 ELEM_CHECK_VARIABLE);
521 /* In case of non-elemental procedures, there is no need to catch
522 dependencies, as we will make a temporary anyway. */
525 /* If the actual arg EXPR is an expression, we need to catch
526 a dependency between variables in EXPR and VAR,
527 an intent((IN)OUT) variable. */
528 if (expr->value.op.op1
529 && gfc_check_argument_var_dependency (var, intent,
531 ELEM_CHECK_VARIABLE))
533 else if (expr->value.op.op2
534 && gfc_check_argument_var_dependency (var, intent,
536 ELEM_CHECK_VARIABLE))
547 /* Like gfc_check_argument_var_dependency, but extended to any
548 array expression OTHER, not just variables. */
551 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
552 gfc_expr *expr, gfc_dep_check elemental)
554 switch (other->expr_type)
557 return gfc_check_argument_var_dependency (other, intent, expr, elemental);
560 if (other->inline_noncopying_intrinsic)
562 other = gfc_get_noncopying_intrinsic_argument (other);
563 return gfc_check_argument_dependency (other, INTENT_IN, expr,
574 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
575 FNSYM is the function being called, or NULL if not known. */
578 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
579 gfc_symbol *fnsym, gfc_actual_arglist *actual,
580 gfc_dep_check elemental)
582 gfc_formal_arglist *formal;
585 formal = fnsym ? fnsym->formal : NULL;
586 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
590 /* Skip args which are not present. */
594 /* Skip other itself. */
598 /* Skip intent(in) arguments if OTHER itself is intent(in). */
599 if (formal && intent == INTENT_IN
600 && formal->sym->attr.intent == INTENT_IN)
603 if (gfc_check_argument_dependency (other, intent, expr, elemental))
611 /* Return 1 if e1 and e2 are equivalenced arrays, either
612 directly or indirectly; i.e., equivalence (a,b) for a and b
613 or equivalence (a,c),(b,c). This function uses the equiv_
614 lists, generated in trans-common(add_equivalences), that are
615 guaranteed to pick up indirect equivalences. We explicitly
616 check for overlap using the offset and length of the equivalence.
617 This function is symmetric.
618 TODO: This function only checks whether the full top-level
619 symbols overlap. An improved implementation could inspect
620 e1->ref and e2->ref to determine whether the actually accessed
621 portions of these variables/arrays potentially overlap. */
624 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
627 gfc_equiv_info *s, *fl1, *fl2;
629 gcc_assert (e1->expr_type == EXPR_VARIABLE
630 && e2->expr_type == EXPR_VARIABLE);
632 if (!e1->symtree->n.sym->attr.in_equivalence
633 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
636 if (e1->symtree->n.sym->ns
637 && e1->symtree->n.sym->ns != gfc_current_ns)
638 l = e1->symtree->n.sym->ns->equiv_lists;
640 l = gfc_current_ns->equiv_lists;
642 /* Go through the equiv_lists and return 1 if the variables
643 e1 and e2 are members of the same group and satisfy the
644 requirement on their relative offsets. */
645 for (; l; l = l->next)
649 for (s = l->equiv; s; s = s->next)
651 if (s->sym == e1->symtree->n.sym)
657 if (s->sym == e2->symtree->n.sym)
667 /* Can these lengths be zero? */
668 if (fl1->length <= 0 || fl2->length <= 0)
670 /* These can't overlap if [f11,fl1+length] is before
671 [fl2,fl2+length], or [fl2,fl2+length] is before
672 [fl1,fl1+length], otherwise they do overlap. */
673 if (fl1->offset + fl1->length > fl2->offset
674 && fl2->offset + fl2->length > fl1->offset)
682 /* Return true if there is no possibility of aliasing because of a type
683 mismatch between all the possible pointer references and the
684 potential target. Note that this function is asymmetric in the
685 arguments and so must be called twice with the arguments exchanged. */
688 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
694 bool seen_component_ref;
696 if (expr1->expr_type != EXPR_VARIABLE
697 || expr1->expr_type != EXPR_VARIABLE)
700 sym1 = expr1->symtree->n.sym;
701 sym2 = expr2->symtree->n.sym;
703 /* Keep it simple for now. */
704 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
707 if (sym1->attr.pointer)
709 if (gfc_compare_types (&sym1->ts, &sym2->ts))
713 /* This is a conservative check on the components of the derived type
714 if no component references have been seen. Since we will not dig
715 into the components of derived type components, we play it safe by
716 returning false. First we check the reference chain and then, if
717 no component references have been seen, the components. */
718 seen_component_ref = false;
719 if (sym1->ts.type == BT_DERIVED)
721 for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
723 if (ref1->type != REF_COMPONENT)
726 if (ref1->u.c.component->ts.type == BT_DERIVED)
729 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
730 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
733 seen_component_ref = true;
737 if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
739 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
741 if (cm1->ts.type == BT_DERIVED)
744 if ((sym2->attr.pointer || cm1->attr.pointer)
745 && gfc_compare_types (&cm1->ts, &sym2->ts))
754 /* Return true if the statement body redefines the condition. Returns
755 true if expr2 depends on expr1. expr1 should be a single term
756 suitable for the lhs of an assignment. The IDENTICAL flag indicates
757 whether array references to the same symbol with identical range
758 references count as a dependency or not. Used for forall and where
759 statements. Also used with functions returning arrays without a
763 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
765 gfc_actual_arglist *actual;
769 gcc_assert (expr1->expr_type == EXPR_VARIABLE);
771 switch (expr2->expr_type)
774 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
777 if (expr2->value.op.op2)
778 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
782 /* The interesting cases are when the symbols don't match. */
783 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
785 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
786 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
788 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
789 if (gfc_are_equivalenced_arrays (expr1, expr2))
792 /* Symbols can only alias if they have the same type. */
793 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
794 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
796 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
800 /* If either variable is a pointer, assume the worst. */
801 /* TODO: -fassume-no-pointer-aliasing */
802 if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
804 if (check_data_pointer_types (expr1, expr2)
805 && check_data_pointer_types (expr2, expr1))
811 /* Otherwise distinct symbols have no dependencies. */
818 /* Identical and disjoint ranges return 0,
819 overlapping ranges return 1. */
820 if (expr1->ref && expr2->ref)
821 return gfc_dep_resolver (expr1->ref, expr2->ref);
826 if (expr2->inline_noncopying_intrinsic)
828 /* Remember possible differences between elemental and
829 transformational functions. All functions inside a FORALL
831 for (actual = expr2->value.function.actual;
832 actual; actual = actual->next)
836 n = gfc_check_dependency (expr1, actual->expr, identical);
847 /* Loop through the array constructor's elements. */
848 for (c = gfc_constructor_first (expr2->value.constructor);
849 c; c = gfc_constructor_next (c))
851 /* If this is an iterator, assume the worst. */
854 /* Avoid recursion in the common case. */
855 if (c->expr->expr_type == EXPR_CONSTANT)
857 if (gfc_check_dependency (expr1, c->expr, 1))
868 /* Determines overlapping for two array sections. */
870 static gfc_dependency
871 gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
892 /* If they are the same range, return without more ado. */
893 if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
894 return GFC_DEP_EQUAL;
896 l_start = l_ar.start[n];
898 l_stride = l_ar.stride[n];
900 r_start = r_ar.start[n];
902 r_stride = r_ar.stride[n];
904 /* If l_start is NULL take it from array specifier. */
905 if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as))
906 l_start = l_ar.as->lower[n];
907 /* If l_end is NULL take it from array specifier. */
908 if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as))
909 l_end = l_ar.as->upper[n];
911 /* If r_start is NULL take it from array specifier. */
912 if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
913 r_start = r_ar.as->lower[n];
914 /* If r_end is NULL take it from array specifier. */
915 if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
916 r_end = r_ar.as->upper[n];
918 /* Determine whether the l_stride is positive or negative. */
921 else if (l_stride->expr_type == EXPR_CONSTANT
922 && l_stride->ts.type == BT_INTEGER)
923 l_dir = mpz_sgn (l_stride->value.integer);
924 else if (l_start && l_end)
925 l_dir = gfc_dep_compare_expr (l_end, l_start);
929 /* Determine whether the r_stride is positive or negative. */
932 else if (r_stride->expr_type == EXPR_CONSTANT
933 && r_stride->ts.type == BT_INTEGER)
934 r_dir = mpz_sgn (r_stride->value.integer);
935 else if (r_start && r_end)
936 r_dir = gfc_dep_compare_expr (r_end, r_start);
940 /* The strides should never be zero. */
941 if (l_dir == 0 || r_dir == 0)
942 return GFC_DEP_OVERLAP;
944 /* Determine LHS upper and lower bounds. */
950 else if (l_dir == -1)
961 /* Determine RHS upper and lower bounds. */
967 else if (r_dir == -1)
978 /* Check whether the ranges are disjoint. */
979 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
980 return GFC_DEP_NODEP;
981 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
982 return GFC_DEP_NODEP;
984 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
985 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
987 if (l_dir == 1 && r_dir == -1)
988 return GFC_DEP_EQUAL;
989 if (l_dir == -1 && r_dir == 1)
990 return GFC_DEP_EQUAL;
993 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
994 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
996 if (l_dir == 1 && r_dir == -1)
997 return GFC_DEP_EQUAL;
998 if (l_dir == -1 && r_dir == 1)
999 return GFC_DEP_EQUAL;
1002 /* Check for forward dependencies x:y vs. x+1:z. */
1003 if (l_dir == 1 && r_dir == 1
1004 && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
1005 && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
1007 /* Check that the strides are the same. */
1008 if (!l_stride && !r_stride)
1009 return GFC_DEP_FORWARD;
1010 if (l_stride && r_stride
1011 && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1012 return GFC_DEP_FORWARD;
1015 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
1016 if (l_dir == -1 && r_dir == -1
1017 && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
1018 && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
1020 /* Check that the strides are the same. */
1021 if (!l_stride && !r_stride)
1022 return GFC_DEP_FORWARD;
1023 if (l_stride && r_stride
1024 && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1025 return GFC_DEP_FORWARD;
1028 return GFC_DEP_OVERLAP;
1032 /* Determines overlapping for a single element and a section. */
1034 static gfc_dependency
1035 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1044 elem = lref->u.ar.start[n];
1046 return GFC_DEP_OVERLAP;
1049 start = ref->start[n] ;
1051 stride = ref->stride[n];
1053 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1054 start = ref->as->lower[n];
1055 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1056 end = ref->as->upper[n];
1058 /* Determine whether the stride is positive or negative. */
1061 else if (stride->expr_type == EXPR_CONSTANT
1062 && stride->ts.type == BT_INTEGER)
1063 s = mpz_sgn (stride->value.integer);
1067 /* Stride should never be zero. */
1069 return GFC_DEP_OVERLAP;
1071 /* Positive strides. */
1074 /* Check for elem < lower. */
1075 if (start && gfc_dep_compare_expr (elem, start) == -1)
1076 return GFC_DEP_NODEP;
1077 /* Check for elem > upper. */
1078 if (end && gfc_dep_compare_expr (elem, end) == 1)
1079 return GFC_DEP_NODEP;
1083 s = gfc_dep_compare_expr (start, end);
1084 /* Check for an empty range. */
1086 return GFC_DEP_NODEP;
1087 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1088 return GFC_DEP_EQUAL;
1091 /* Negative strides. */
1094 /* Check for elem > upper. */
1095 if (end && gfc_dep_compare_expr (elem, start) == 1)
1096 return GFC_DEP_NODEP;
1097 /* Check for elem < lower. */
1098 if (start && gfc_dep_compare_expr (elem, end) == -1)
1099 return GFC_DEP_NODEP;
1103 s = gfc_dep_compare_expr (start, end);
1104 /* Check for an empty range. */
1106 return GFC_DEP_NODEP;
1107 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1108 return GFC_DEP_EQUAL;
1111 /* Unknown strides. */
1115 return GFC_DEP_OVERLAP;
1116 s = gfc_dep_compare_expr (start, end);
1118 return GFC_DEP_OVERLAP;
1119 /* Assume positive stride. */
1122 /* Check for elem < lower. */
1123 if (gfc_dep_compare_expr (elem, start) == -1)
1124 return GFC_DEP_NODEP;
1125 /* Check for elem > upper. */
1126 if (gfc_dep_compare_expr (elem, end) == 1)
1127 return GFC_DEP_NODEP;
1129 /* Assume negative stride. */
1132 /* Check for elem > upper. */
1133 if (gfc_dep_compare_expr (elem, start) == 1)
1134 return GFC_DEP_NODEP;
1135 /* Check for elem < lower. */
1136 if (gfc_dep_compare_expr (elem, end) == -1)
1137 return GFC_DEP_NODEP;
1142 s = gfc_dep_compare_expr (elem, start);
1144 return GFC_DEP_EQUAL;
1145 if (s == 1 || s == -1)
1146 return GFC_DEP_NODEP;
1150 return GFC_DEP_OVERLAP;
1154 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1155 forall_index attribute. Return true if any variable may be
1156 being used as a FORALL index. Its safe to pessimistically
1157 return true, and assume a dependency. */
1160 contains_forall_index_p (gfc_expr *expr)
1162 gfc_actual_arglist *arg;
1170 switch (expr->expr_type)
1173 if (expr->symtree->n.sym->forall_index)
1178 if (contains_forall_index_p (expr->value.op.op1)
1179 || contains_forall_index_p (expr->value.op.op2))
1184 for (arg = expr->value.function.actual; arg; arg = arg->next)
1185 if (contains_forall_index_p (arg->expr))
1191 case EXPR_SUBSTRING:
1194 case EXPR_STRUCTURE:
1196 for (c = gfc_constructor_first (expr->value.constructor);
1197 c; gfc_constructor_next (c))
1198 if (contains_forall_index_p (c->expr))
1206 for (ref = expr->ref; ref; ref = ref->next)
1210 for (i = 0; i < ref->u.ar.dimen; i++)
1211 if (contains_forall_index_p (ref->u.ar.start[i])
1212 || contains_forall_index_p (ref->u.ar.end[i])
1213 || contains_forall_index_p (ref->u.ar.stride[i]))
1221 if (contains_forall_index_p (ref->u.ss.start)
1222 || contains_forall_index_p (ref->u.ss.end))
1233 /* Determines overlapping for two single element array references. */
1235 static gfc_dependency
1236 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1246 l_start = l_ar.start[n] ;
1247 r_start = r_ar.start[n] ;
1248 i = gfc_dep_compare_expr (r_start, l_start);
1250 return GFC_DEP_EQUAL;
1252 /* Treat two scalar variables as potentially equal. This allows
1253 us to prove that a(i,:) and a(j,:) have no dependency. See
1254 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1255 Proceedings of the International Conference on Parallel and
1256 Distributed Processing Techniques and Applications (PDPTA2001),
1257 Las Vegas, Nevada, June 2001. */
1258 /* However, we need to be careful when either scalar expression
1259 contains a FORALL index, as these can potentially change value
1260 during the scalarization/traversal of this array reference. */
1261 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1262 return GFC_DEP_OVERLAP;
1265 return GFC_DEP_NODEP;
1266 return GFC_DEP_EQUAL;
1270 /* Determine if an array ref, usually an array section specifies the
1271 entire array. In addition, if the second, pointer argument is
1272 provided, the function will return true if the reference is
1273 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1276 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1280 bool lbound_OK = true;
1281 bool ubound_OK = true;
1284 *contiguous = false;
1286 if (ref->type != REF_ARRAY)
1289 if (ref->u.ar.type == AR_FULL)
1296 if (ref->u.ar.type != AR_SECTION)
1301 for (i = 0; i < ref->u.ar.dimen; i++)
1303 /* If we have a single element in the reference, for the reference
1304 to be full, we need to ascertain that the array has a single
1305 element in this dimension and that we actually reference the
1307 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1309 /* This is unconditionally a contiguous reference if all the
1310 remaining dimensions are elements. */
1314 for (n = i + 1; n < ref->u.ar.dimen; n++)
1315 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1316 *contiguous = false;
1320 || !ref->u.ar.as->lower[i]
1321 || !ref->u.ar.as->upper[i]
1322 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1323 ref->u.ar.as->upper[i])
1324 || !ref->u.ar.start[i]
1325 || gfc_dep_compare_expr (ref->u.ar.start[i],
1326 ref->u.ar.as->lower[i]))
1332 /* Check the lower bound. */
1333 if (ref->u.ar.start[i]
1335 || !ref->u.ar.as->lower[i]
1336 || gfc_dep_compare_expr (ref->u.ar.start[i],
1337 ref->u.ar.as->lower[i])))
1339 /* Check the upper bound. */
1340 if (ref->u.ar.end[i]
1342 || !ref->u.ar.as->upper[i]
1343 || gfc_dep_compare_expr (ref->u.ar.end[i],
1344 ref->u.ar.as->upper[i])))
1346 /* Check the stride. */
1347 if (ref->u.ar.stride[i]
1348 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1351 /* This is unconditionally a contiguous reference as long as all
1352 the subsequent dimensions are elements. */
1356 for (n = i + 1; n < ref->u.ar.dimen; n++)
1357 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1358 *contiguous = false;
1361 if (!lbound_OK || !ubound_OK)
1368 /* Determine if a full array is the same as an array section with one
1369 variable limit. For this to be so, the strides must both be unity
1370 and one of either start == lower or end == upper must be true. */
1373 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1376 bool upper_or_lower;
1378 if (full_ref->type != REF_ARRAY)
1380 if (full_ref->u.ar.type != AR_FULL)
1382 if (ref->type != REF_ARRAY)
1384 if (ref->u.ar.type != AR_SECTION)
1387 for (i = 0; i < ref->u.ar.dimen; i++)
1389 /* If we have a single element in the reference, we need to check
1390 that the array has a single element and that we actually reference
1391 the correct element. */
1392 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1394 if (!full_ref->u.ar.as
1395 || !full_ref->u.ar.as->lower[i]
1396 || !full_ref->u.ar.as->upper[i]
1397 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1398 full_ref->u.ar.as->upper[i])
1399 || !ref->u.ar.start[i]
1400 || gfc_dep_compare_expr (ref->u.ar.start[i],
1401 full_ref->u.ar.as->lower[i]))
1405 /* Check the strides. */
1406 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1408 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1411 upper_or_lower = false;
1412 /* Check the lower bound. */
1413 if (ref->u.ar.start[i]
1415 && full_ref->u.ar.as->lower[i]
1416 && gfc_dep_compare_expr (ref->u.ar.start[i],
1417 full_ref->u.ar.as->lower[i]) == 0))
1418 upper_or_lower = true;
1419 /* Check the upper bound. */
1420 if (ref->u.ar.end[i]
1422 && full_ref->u.ar.as->upper[i]
1423 && gfc_dep_compare_expr (ref->u.ar.end[i],
1424 full_ref->u.ar.as->upper[i]) == 0))
1425 upper_or_lower = true;
1426 if (!upper_or_lower)
1433 /* Finds if two array references are overlapping or not.
1435 1 : array references are overlapping.
1436 0 : array references are identical or not overlapping. */
1439 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
1442 gfc_dependency fin_dep;
1443 gfc_dependency this_dep;
1445 fin_dep = GFC_DEP_ERROR;
1446 /* Dependencies due to pointers should already have been identified.
1447 We only need to check for overlapping array references. */
1449 while (lref && rref)
1451 /* We're resolving from the same base symbol, so both refs should be
1452 the same type. We traverse the reference chain until we find ranges
1453 that are not equal. */
1454 gcc_assert (lref->type == rref->type);
1458 /* The two ranges can't overlap if they are from different
1460 if (lref->u.c.component != rref->u.c.component)
1465 /* Substring overlaps are handled by the string assignment code
1466 if there is not an underlying dependency. */
1467 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1471 if (ref_same_as_full_array (lref, rref))
1474 if (ref_same_as_full_array (rref, lref))
1477 if (lref->u.ar.dimen != rref->u.ar.dimen)
1479 if (lref->u.ar.type == AR_FULL)
1480 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1482 else if (rref->u.ar.type == AR_FULL)
1483 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1490 for (n=0; n < lref->u.ar.dimen; n++)
1492 /* Assume dependency when either of array reference is vector
1494 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1495 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1497 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1498 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1499 this_dep = gfc_check_section_vs_section (lref, rref, n);
1500 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1501 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1502 this_dep = gfc_check_element_vs_section (lref, rref, n);
1503 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1504 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1505 this_dep = gfc_check_element_vs_section (rref, lref, n);
1508 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1509 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1510 this_dep = gfc_check_element_vs_element (rref, lref, n);
1513 /* If any dimension doesn't overlap, we have no dependency. */
1514 if (this_dep == GFC_DEP_NODEP)
1517 /* Overlap codes are in order of priority. We only need to
1518 know the worst one.*/
1519 if (this_dep > fin_dep)
1523 /* If this is an equal element, we have to keep going until we find
1524 the "real" array reference. */
1525 if (lref->u.ar.type == AR_ELEMENT
1526 && rref->u.ar.type == AR_ELEMENT
1527 && fin_dep == GFC_DEP_EQUAL)
1530 /* Exactly matching and forward overlapping ranges don't cause a
1532 if (fin_dep < GFC_DEP_OVERLAP)
1535 /* Keep checking. We only have a dependency if
1536 subsequent references also overlap. */
1546 /* If we haven't seen any array refs then something went wrong. */
1547 gcc_assert (fin_dep != GFC_DEP_ERROR);
1549 /* Assume the worst if we nest to different depths. */
1553 return fin_dep == GFC_DEP_OVERLAP;