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 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1003 There is no dependency if the remainder of
1004 (l_start - r_start) / gcd(l_stride, r_stride) is
1007 - Handle cases where x is an expression.
1008 - Cases like a(1:4:2) = a(2:3) are still not handled.
1011 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1012 && (a)->ts.type == BT_INTEGER)
1014 if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start)
1015 && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride))
1023 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1024 mpz_sub (tmp, l_start->value.integer, r_start->value.integer);
1026 mpz_fdiv_r (tmp, tmp, gcd);
1027 result = mpz_cmp_si (tmp, 0L);
1033 return GFC_DEP_NODEP;
1036 #undef IS_CONSTANT_INTEGER
1038 /* Check for forward dependencies x:y vs. x+1:z. */
1039 if (l_dir == 1 && r_dir == 1
1040 && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
1041 && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
1043 /* Check that the strides are the same. */
1044 if (!l_stride && !r_stride)
1045 return GFC_DEP_FORWARD;
1046 if (l_stride && r_stride
1047 && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1048 return GFC_DEP_FORWARD;
1051 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
1052 if (l_dir == -1 && r_dir == -1
1053 && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
1054 && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
1056 /* Check that the strides are the same. */
1057 if (!l_stride && !r_stride)
1058 return GFC_DEP_FORWARD;
1059 if (l_stride && r_stride
1060 && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1061 return GFC_DEP_FORWARD;
1064 return GFC_DEP_OVERLAP;
1068 /* Determines overlapping for a single element and a section. */
1070 static gfc_dependency
1071 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1080 elem = lref->u.ar.start[n];
1082 return GFC_DEP_OVERLAP;
1085 start = ref->start[n] ;
1087 stride = ref->stride[n];
1089 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1090 start = ref->as->lower[n];
1091 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1092 end = ref->as->upper[n];
1094 /* Determine whether the stride is positive or negative. */
1097 else if (stride->expr_type == EXPR_CONSTANT
1098 && stride->ts.type == BT_INTEGER)
1099 s = mpz_sgn (stride->value.integer);
1103 /* Stride should never be zero. */
1105 return GFC_DEP_OVERLAP;
1107 /* Positive strides. */
1110 /* Check for elem < lower. */
1111 if (start && gfc_dep_compare_expr (elem, start) == -1)
1112 return GFC_DEP_NODEP;
1113 /* Check for elem > upper. */
1114 if (end && gfc_dep_compare_expr (elem, end) == 1)
1115 return GFC_DEP_NODEP;
1119 s = gfc_dep_compare_expr (start, end);
1120 /* Check for an empty range. */
1122 return GFC_DEP_NODEP;
1123 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1124 return GFC_DEP_EQUAL;
1127 /* Negative strides. */
1130 /* Check for elem > upper. */
1131 if (end && gfc_dep_compare_expr (elem, start) == 1)
1132 return GFC_DEP_NODEP;
1133 /* Check for elem < lower. */
1134 if (start && gfc_dep_compare_expr (elem, end) == -1)
1135 return GFC_DEP_NODEP;
1139 s = gfc_dep_compare_expr (start, end);
1140 /* Check for an empty range. */
1142 return GFC_DEP_NODEP;
1143 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1144 return GFC_DEP_EQUAL;
1147 /* Unknown strides. */
1151 return GFC_DEP_OVERLAP;
1152 s = gfc_dep_compare_expr (start, end);
1154 return GFC_DEP_OVERLAP;
1155 /* Assume positive stride. */
1158 /* Check for elem < lower. */
1159 if (gfc_dep_compare_expr (elem, start) == -1)
1160 return GFC_DEP_NODEP;
1161 /* Check for elem > upper. */
1162 if (gfc_dep_compare_expr (elem, end) == 1)
1163 return GFC_DEP_NODEP;
1165 /* Assume negative stride. */
1168 /* Check for elem > upper. */
1169 if (gfc_dep_compare_expr (elem, start) == 1)
1170 return GFC_DEP_NODEP;
1171 /* Check for elem < lower. */
1172 if (gfc_dep_compare_expr (elem, end) == -1)
1173 return GFC_DEP_NODEP;
1178 s = gfc_dep_compare_expr (elem, start);
1180 return GFC_DEP_EQUAL;
1181 if (s == 1 || s == -1)
1182 return GFC_DEP_NODEP;
1186 return GFC_DEP_OVERLAP;
1190 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1191 forall_index attribute. Return true if any variable may be
1192 being used as a FORALL index. Its safe to pessimistically
1193 return true, and assume a dependency. */
1196 contains_forall_index_p (gfc_expr *expr)
1198 gfc_actual_arglist *arg;
1206 switch (expr->expr_type)
1209 if (expr->symtree->n.sym->forall_index)
1214 if (contains_forall_index_p (expr->value.op.op1)
1215 || contains_forall_index_p (expr->value.op.op2))
1220 for (arg = expr->value.function.actual; arg; arg = arg->next)
1221 if (contains_forall_index_p (arg->expr))
1227 case EXPR_SUBSTRING:
1230 case EXPR_STRUCTURE:
1232 for (c = gfc_constructor_first (expr->value.constructor);
1233 c; gfc_constructor_next (c))
1234 if (contains_forall_index_p (c->expr))
1242 for (ref = expr->ref; ref; ref = ref->next)
1246 for (i = 0; i < ref->u.ar.dimen; i++)
1247 if (contains_forall_index_p (ref->u.ar.start[i])
1248 || contains_forall_index_p (ref->u.ar.end[i])
1249 || contains_forall_index_p (ref->u.ar.stride[i]))
1257 if (contains_forall_index_p (ref->u.ss.start)
1258 || contains_forall_index_p (ref->u.ss.end))
1269 /* Determines overlapping for two single element array references. */
1271 static gfc_dependency
1272 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1282 l_start = l_ar.start[n] ;
1283 r_start = r_ar.start[n] ;
1284 i = gfc_dep_compare_expr (r_start, l_start);
1286 return GFC_DEP_EQUAL;
1288 /* Treat two scalar variables as potentially equal. This allows
1289 us to prove that a(i,:) and a(j,:) have no dependency. See
1290 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1291 Proceedings of the International Conference on Parallel and
1292 Distributed Processing Techniques and Applications (PDPTA2001),
1293 Las Vegas, Nevada, June 2001. */
1294 /* However, we need to be careful when either scalar expression
1295 contains a FORALL index, as these can potentially change value
1296 during the scalarization/traversal of this array reference. */
1297 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1298 return GFC_DEP_OVERLAP;
1301 return GFC_DEP_NODEP;
1302 return GFC_DEP_EQUAL;
1306 /* Determine if an array ref, usually an array section specifies the
1307 entire array. In addition, if the second, pointer argument is
1308 provided, the function will return true if the reference is
1309 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1312 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1316 bool lbound_OK = true;
1317 bool ubound_OK = true;
1320 *contiguous = false;
1322 if (ref->type != REF_ARRAY)
1325 if (ref->u.ar.type == AR_FULL)
1332 if (ref->u.ar.type != AR_SECTION)
1337 for (i = 0; i < ref->u.ar.dimen; i++)
1339 /* If we have a single element in the reference, for the reference
1340 to be full, we need to ascertain that the array has a single
1341 element in this dimension and that we actually reference the
1343 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1345 /* This is unconditionally a contiguous reference if all the
1346 remaining dimensions are elements. */
1350 for (n = i + 1; n < ref->u.ar.dimen; n++)
1351 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1352 *contiguous = false;
1356 || !ref->u.ar.as->lower[i]
1357 || !ref->u.ar.as->upper[i]
1358 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1359 ref->u.ar.as->upper[i])
1360 || !ref->u.ar.start[i]
1361 || gfc_dep_compare_expr (ref->u.ar.start[i],
1362 ref->u.ar.as->lower[i]))
1368 /* Check the lower bound. */
1369 if (ref->u.ar.start[i]
1371 || !ref->u.ar.as->lower[i]
1372 || gfc_dep_compare_expr (ref->u.ar.start[i],
1373 ref->u.ar.as->lower[i])))
1375 /* Check the upper bound. */
1376 if (ref->u.ar.end[i]
1378 || !ref->u.ar.as->upper[i]
1379 || gfc_dep_compare_expr (ref->u.ar.end[i],
1380 ref->u.ar.as->upper[i])))
1382 /* Check the stride. */
1383 if (ref->u.ar.stride[i]
1384 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1387 /* This is unconditionally a contiguous reference as long as all
1388 the subsequent dimensions are elements. */
1392 for (n = i + 1; n < ref->u.ar.dimen; n++)
1393 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1394 *contiguous = false;
1397 if (!lbound_OK || !ubound_OK)
1404 /* Determine if a full array is the same as an array section with one
1405 variable limit. For this to be so, the strides must both be unity
1406 and one of either start == lower or end == upper must be true. */
1409 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1412 bool upper_or_lower;
1414 if (full_ref->type != REF_ARRAY)
1416 if (full_ref->u.ar.type != AR_FULL)
1418 if (ref->type != REF_ARRAY)
1420 if (ref->u.ar.type != AR_SECTION)
1423 for (i = 0; i < ref->u.ar.dimen; i++)
1425 /* If we have a single element in the reference, we need to check
1426 that the array has a single element and that we actually reference
1427 the correct element. */
1428 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1430 if (!full_ref->u.ar.as
1431 || !full_ref->u.ar.as->lower[i]
1432 || !full_ref->u.ar.as->upper[i]
1433 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1434 full_ref->u.ar.as->upper[i])
1435 || !ref->u.ar.start[i]
1436 || gfc_dep_compare_expr (ref->u.ar.start[i],
1437 full_ref->u.ar.as->lower[i]))
1441 /* Check the strides. */
1442 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1444 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1447 upper_or_lower = false;
1448 /* Check the lower bound. */
1449 if (ref->u.ar.start[i]
1451 && full_ref->u.ar.as->lower[i]
1452 && gfc_dep_compare_expr (ref->u.ar.start[i],
1453 full_ref->u.ar.as->lower[i]) == 0))
1454 upper_or_lower = true;
1455 /* Check the upper bound. */
1456 if (ref->u.ar.end[i]
1458 && full_ref->u.ar.as->upper[i]
1459 && gfc_dep_compare_expr (ref->u.ar.end[i],
1460 full_ref->u.ar.as->upper[i]) == 0))
1461 upper_or_lower = true;
1462 if (!upper_or_lower)
1469 /* Finds if two array references are overlapping or not.
1471 1 : array references are overlapping.
1472 0 : array references are identical or not overlapping. */
1475 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
1478 gfc_dependency fin_dep;
1479 gfc_dependency this_dep;
1481 fin_dep = GFC_DEP_ERROR;
1482 /* Dependencies due to pointers should already have been identified.
1483 We only need to check for overlapping array references. */
1485 while (lref && rref)
1487 /* We're resolving from the same base symbol, so both refs should be
1488 the same type. We traverse the reference chain until we find ranges
1489 that are not equal. */
1490 gcc_assert (lref->type == rref->type);
1494 /* The two ranges can't overlap if they are from different
1496 if (lref->u.c.component != rref->u.c.component)
1501 /* Substring overlaps are handled by the string assignment code
1502 if there is not an underlying dependency. */
1503 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1507 if (ref_same_as_full_array (lref, rref))
1510 if (ref_same_as_full_array (rref, lref))
1513 if (lref->u.ar.dimen != rref->u.ar.dimen)
1515 if (lref->u.ar.type == AR_FULL)
1516 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1518 else if (rref->u.ar.type == AR_FULL)
1519 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1526 for (n=0; n < lref->u.ar.dimen; n++)
1528 /* Assume dependency when either of array reference is vector
1530 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1531 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1533 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1534 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1535 this_dep = gfc_check_section_vs_section (lref, rref, n);
1536 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1537 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1538 this_dep = gfc_check_element_vs_section (lref, rref, n);
1539 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1540 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1541 this_dep = gfc_check_element_vs_section (rref, lref, n);
1544 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1545 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1546 this_dep = gfc_check_element_vs_element (rref, lref, n);
1549 /* If any dimension doesn't overlap, we have no dependency. */
1550 if (this_dep == GFC_DEP_NODEP)
1553 /* Overlap codes are in order of priority. We only need to
1554 know the worst one.*/
1555 if (this_dep > fin_dep)
1559 /* If this is an equal element, we have to keep going until we find
1560 the "real" array reference. */
1561 if (lref->u.ar.type == AR_ELEMENT
1562 && rref->u.ar.type == AR_ELEMENT
1563 && fin_dep == GFC_DEP_EQUAL)
1566 /* Exactly matching and forward overlapping ranges don't cause a
1568 if (fin_dep < GFC_DEP_OVERLAP)
1571 /* Keep checking. We only have a dependency if
1572 subsequent references also overlap. */
1582 /* If we haven't seen any array refs then something went wrong. */
1583 gcc_assert (fin_dep != GFC_DEP_ERROR);
1585 /* Assume the worst if we nest to different depths. */
1589 return fin_dep == GFC_DEP_OVERLAP;