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. */
29 #include "dependency.h"
30 #include "constructor.h"
32 /* static declarations */
34 enum range
{LHS
, RHS
, MID
};
36 /* Dependency types. These must be in reverse order of priority. */
40 GFC_DEP_EQUAL
, /* Identical Ranges. */
41 GFC_DEP_FORWARD
, /* e.g., a(1:3), a(2:4). */
42 GFC_DEP_OVERLAP
, /* May overlap in some other way. */
43 GFC_DEP_NODEP
/* Distinct ranges. */
48 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
51 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
52 def if the value could not be determined. */
55 gfc_expr_is_one (gfc_expr
*expr
, int def
)
57 gcc_assert (expr
!= NULL
);
59 if (expr
->expr_type
!= EXPR_CONSTANT
)
62 if (expr
->ts
.type
!= BT_INTEGER
)
65 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
69 /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
70 and -2 if the relationship could not be determined. */
73 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
75 gfc_actual_arglist
*args1
;
76 gfc_actual_arglist
*args2
;
79 if (e1
->expr_type
== EXPR_OP
80 && (e1
->value
.op
.op
== INTRINSIC_UPLUS
81 || e1
->value
.op
.op
== INTRINSIC_PARENTHESES
))
82 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
83 if (e2
->expr_type
== EXPR_OP
84 && (e2
->value
.op
.op
== INTRINSIC_UPLUS
85 || e2
->value
.op
.op
== INTRINSIC_PARENTHESES
))
86 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
88 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
90 /* Compare X+C vs. X. */
91 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
92 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
93 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
94 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
96 /* Compare P+Q vs. R+S. */
97 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
101 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
102 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
103 if (l
== 0 && r
== 0)
105 if (l
== 0 && r
!= -2)
107 if (l
!= -2 && r
== 0)
109 if (l
== 1 && r
== 1)
111 if (l
== -1 && r
== -1)
114 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
115 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
116 if (l
== 0 && r
== 0)
118 if (l
== 0 && r
!= -2)
120 if (l
!= -2 && r
== 0)
122 if (l
== 1 && r
== 1)
124 if (l
== -1 && r
== -1)
129 /* Compare X vs. X+C. */
130 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
132 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
133 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
134 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
135 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
138 /* Compare X-C vs. X. */
139 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
141 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
142 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
143 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
144 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
146 /* Compare P-Q vs. R-S. */
147 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
151 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
152 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
153 if (l
== 0 && r
== 0)
155 if (l
!= -2 && r
== 0)
157 if (l
== 0 && r
!= -2)
159 if (l
== 1 && r
== -1)
161 if (l
== -1 && r
== 1)
166 /* Compare X vs. X-C. */
167 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
169 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
170 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
171 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
172 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
175 if (e1
->expr_type
!= e2
->expr_type
)
178 switch (e1
->expr_type
)
181 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
184 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
192 if (e1
->ref
|| e2
->ref
)
194 if (e1
->symtree
->n
.sym
== e2
->symtree
->n
.sym
)
199 /* Intrinsic operators are the same if their operands are the same. */
200 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
202 if (e1
->value
.op
.op2
== 0)
204 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
205 return i
== 0 ? 0 : -2;
207 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
208 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
210 /* TODO Handle commutative binary operators here? */
214 /* We can only compare calls to the same intrinsic function. */
215 if (e1
->value
.function
.isym
== 0 || e2
->value
.function
.isym
== 0
216 || e1
->value
.function
.isym
!= e2
->value
.function
.isym
)
219 args1
= e1
->value
.function
.actual
;
220 args2
= e2
->value
.function
.actual
;
222 /* We should list the "constant" intrinsic functions. Those
223 without side-effects that provide equal results given equal
225 switch (e1
->value
.function
.isym
->id
)
227 case GFC_ISYM_CONVERSION
:
228 /* Handle integer extensions specially, as __convert_i4_i8
229 is not only "constant" but also "unary" and "increasing". */
230 if (args1
&& !args1
->next
231 && args2
&& !args2
->next
232 && e1
->ts
.type
== BT_INTEGER
233 && args1
->expr
->ts
.type
== BT_INTEGER
234 && e1
->ts
.kind
> args1
->expr
->ts
.kind
235 && e2
->ts
.type
== e1
->ts
.type
236 && e2
->ts
.kind
== e1
->ts
.kind
237 && args2
->expr
->ts
.type
== args1
->expr
->ts
.type
238 && args2
->expr
->ts
.kind
== args2
->expr
->ts
.kind
)
239 return gfc_dep_compare_expr (args1
->expr
, args2
->expr
);
243 case GFC_ISYM_LOGICAL
:
251 /* Compare the argument lists for equality. */
252 while (args1
&& args2
)
254 if (gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
259 return (args1
|| args2
) ? -2 : 0;
267 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
268 if the results are indeterminate. N is the dimension to compare. */
271 gfc_is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
, int def
)
277 /* TODO: More sophisticated range comparison. */
278 gcc_assert (ar1
&& ar2
);
280 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
284 /* Check for mismatching strides. A NULL stride means a stride of 1. */
287 i
= gfc_expr_is_one (e1
, -1);
295 i
= gfc_expr_is_one (e2
, -1);
303 i
= gfc_dep_compare_expr (e1
, e2
);
309 /* The strides match. */
311 /* Check the range start. */
316 /* Use the bound of the array if no bound is specified. */
318 e1
= ar1
->as
->lower
[n
];
321 e2
= ar2
->as
->lower
[n
];
323 /* Check we have values for both. */
327 i
= gfc_dep_compare_expr (e1
, e2
);
334 /* Check the range end. */
339 /* Use the bound of the array if no bound is specified. */
341 e1
= ar1
->as
->upper
[n
];
344 e2
= ar2
->as
->upper
[n
];
346 /* Check we have values for both. */
350 i
= gfc_dep_compare_expr (e1
, e2
);
361 /* Some array-returning intrinsics can be implemented by reusing the
362 data from one of the array arguments. For example, TRANSPOSE does
363 not necessarily need to allocate new data: it can be implemented
364 by copying the original array's descriptor and simply swapping the
365 two dimension specifications.
367 If EXPR is a call to such an intrinsic, return the argument
368 whose data can be reused, otherwise return NULL. */
371 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
373 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
376 switch (expr
->value
.function
.isym
->id
)
378 case GFC_ISYM_TRANSPOSE
:
379 return expr
->value
.function
.actual
->expr
;
387 /* Return true if the result of reference REF can only be constructed
388 using a temporary array. */
391 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
397 for (; ref
; ref
= ref
->next
)
401 /* Vector dimensions are generally not monotonic and must be
402 handled using a temporary. */
403 if (ref
->u
.ar
.type
== AR_SECTION
)
404 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
405 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
412 /* Within an array reference, character substrings generally
413 need a temporary. Character array strides are expressed as
414 multiples of the element size (consistent with other array
415 types), not in characters. */
427 gfc_is_data_pointer (gfc_expr
*e
)
431 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
434 /* No subreference if it is a function */
435 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
437 if (e
->symtree
->n
.sym
->attr
.pointer
)
440 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
441 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
448 /* Return true if array variable VAR could be passed to the same function
449 as argument EXPR without interfering with EXPR. INTENT is the intent
452 This is considerably less conservative than other dependencies
453 because many function arguments will already be copied into a
457 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
458 gfc_expr
*expr
, gfc_dep_check elemental
)
462 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
463 gcc_assert (var
->rank
> 0);
465 switch (expr
->expr_type
)
468 /* In case of elemental subroutines, there is no dependency
469 between two same-range array references. */
470 if (gfc_ref_needs_temporary_p (expr
->ref
)
471 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
473 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
475 /* Too many false positive with pointers. */
476 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
478 /* Elemental procedures forbid unspecified intents,
479 and we don't check dependencies for INTENT_IN args. */
480 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
482 /* We are told not to check dependencies.
483 We do it, however, and issue a warning in case we find one.
484 If a dependency is found in the case
485 elemental == ELEM_CHECK_VARIABLE, we will generate
486 a temporary, so we don't need to bother the user. */
487 gfc_warning ("INTENT(%s) actual argument at %L might "
488 "interfere with actual argument at %L.",
489 intent
== INTENT_OUT
? "OUT" : "INOUT",
490 &var
->where
, &expr
->where
);
500 return gfc_check_dependency (var
, expr
, 1);
503 if (intent
!= INTENT_IN
&& expr
->inline_noncopying_intrinsic
504 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
))
505 && gfc_check_argument_var_dependency (var
, intent
, arg
, elemental
))
509 if ((expr
->value
.function
.esym
510 && expr
->value
.function
.esym
->attr
.elemental
)
511 || (expr
->value
.function
.isym
512 && expr
->value
.function
.isym
->elemental
))
513 return gfc_check_fncall_dependency (var
, intent
, NULL
,
514 expr
->value
.function
.actual
,
515 ELEM_CHECK_VARIABLE
);
520 /* In case of non-elemental procedures, there is no need to catch
521 dependencies, as we will make a temporary anyway. */
524 /* If the actual arg EXPR is an expression, we need to catch
525 a dependency between variables in EXPR and VAR,
526 an intent((IN)OUT) variable. */
527 if (expr
->value
.op
.op1
528 && gfc_check_argument_var_dependency (var
, intent
,
530 ELEM_CHECK_VARIABLE
))
532 else if (expr
->value
.op
.op2
533 && gfc_check_argument_var_dependency (var
, intent
,
535 ELEM_CHECK_VARIABLE
))
546 /* Like gfc_check_argument_var_dependency, but extended to any
547 array expression OTHER, not just variables. */
550 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
551 gfc_expr
*expr
, gfc_dep_check elemental
)
553 switch (other
->expr_type
)
556 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
559 if (other
->inline_noncopying_intrinsic
)
561 other
= gfc_get_noncopying_intrinsic_argument (other
);
562 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
573 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
574 FNSYM is the function being called, or NULL if not known. */
577 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
578 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
579 gfc_dep_check elemental
)
581 gfc_formal_arglist
*formal
;
584 formal
= fnsym
? fnsym
->formal
: NULL
;
585 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
589 /* Skip args which are not present. */
593 /* Skip other itself. */
597 /* Skip intent(in) arguments if OTHER itself is intent(in). */
598 if (formal
&& intent
== INTENT_IN
599 && formal
->sym
->attr
.intent
== INTENT_IN
)
602 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
610 /* Return 1 if e1 and e2 are equivalenced arrays, either
611 directly or indirectly; i.e., equivalence (a,b) for a and b
612 or equivalence (a,c),(b,c). This function uses the equiv_
613 lists, generated in trans-common(add_equivalences), that are
614 guaranteed to pick up indirect equivalences. We explicitly
615 check for overlap using the offset and length of the equivalence.
616 This function is symmetric.
617 TODO: This function only checks whether the full top-level
618 symbols overlap. An improved implementation could inspect
619 e1->ref and e2->ref to determine whether the actually accessed
620 portions of these variables/arrays potentially overlap. */
623 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
626 gfc_equiv_info
*s
, *fl1
, *fl2
;
628 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
629 && e2
->expr_type
== EXPR_VARIABLE
);
631 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
632 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
635 if (e1
->symtree
->n
.sym
->ns
636 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
637 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
639 l
= gfc_current_ns
->equiv_lists
;
641 /* Go through the equiv_lists and return 1 if the variables
642 e1 and e2 are members of the same group and satisfy the
643 requirement on their relative offsets. */
644 for (; l
; l
= l
->next
)
648 for (s
= l
->equiv
; s
; s
= s
->next
)
650 if (s
->sym
== e1
->symtree
->n
.sym
)
656 if (s
->sym
== e2
->symtree
->n
.sym
)
666 /* Can these lengths be zero? */
667 if (fl1
->length
<= 0 || fl2
->length
<= 0)
669 /* These can't overlap if [f11,fl1+length] is before
670 [fl2,fl2+length], or [fl2,fl2+length] is before
671 [fl1,fl1+length], otherwise they do overlap. */
672 if (fl1
->offset
+ fl1
->length
> fl2
->offset
673 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
681 /* Return true if there is no possibility of aliasing because of a type
682 mismatch between all the possible pointer references and the
683 potential target. Note that this function is asymmetric in the
684 arguments and so must be called twice with the arguments exchanged. */
687 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
693 bool seen_component_ref
;
695 if (expr1
->expr_type
!= EXPR_VARIABLE
696 || expr1
->expr_type
!= EXPR_VARIABLE
)
699 sym1
= expr1
->symtree
->n
.sym
;
700 sym2
= expr2
->symtree
->n
.sym
;
702 /* Keep it simple for now. */
703 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
706 if (sym1
->attr
.pointer
)
708 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
712 /* This is a conservative check on the components of the derived type
713 if no component references have been seen. Since we will not dig
714 into the components of derived type components, we play it safe by
715 returning false. First we check the reference chain and then, if
716 no component references have been seen, the components. */
717 seen_component_ref
= false;
718 if (sym1
->ts
.type
== BT_DERIVED
)
720 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
722 if (ref1
->type
!= REF_COMPONENT
)
725 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
728 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
729 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
732 seen_component_ref
= true;
736 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
738 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
740 if (cm1
->ts
.type
== BT_DERIVED
)
743 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
744 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
753 /* Return true if the statement body redefines the condition. Returns
754 true if expr2 depends on expr1. expr1 should be a single term
755 suitable for the lhs of an assignment. The IDENTICAL flag indicates
756 whether array references to the same symbol with identical range
757 references count as a dependency or not. Used for forall and where
758 statements. Also used with functions returning arrays without a
762 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
764 gfc_actual_arglist
*actual
;
768 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
770 switch (expr2
->expr_type
)
773 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
776 if (expr2
->value
.op
.op2
)
777 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
781 /* The interesting cases are when the symbols don't match. */
782 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
784 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
785 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
787 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
788 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
791 /* Symbols can only alias if they have the same type. */
792 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
793 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
795 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
799 /* If either variable is a pointer, assume the worst. */
800 /* TODO: -fassume-no-pointer-aliasing */
801 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
803 if (check_data_pointer_types (expr1
, expr2
)
804 && check_data_pointer_types (expr2
, expr1
))
810 /* Otherwise distinct symbols have no dependencies. */
817 /* Identical and disjoint ranges return 0,
818 overlapping ranges return 1. */
819 if (expr1
->ref
&& expr2
->ref
)
820 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
);
825 if (expr2
->inline_noncopying_intrinsic
)
827 /* Remember possible differences between elemental and
828 transformational functions. All functions inside a FORALL
830 for (actual
= expr2
->value
.function
.actual
;
831 actual
; actual
= actual
->next
)
835 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
846 /* Loop through the array constructor's elements. */
847 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
848 c
; c
= gfc_constructor_next (c
))
850 /* If this is an iterator, assume the worst. */
853 /* Avoid recursion in the common case. */
854 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
856 if (gfc_check_dependency (expr1
, c
->expr
, 1))
867 /* Determines overlapping for two array sections. */
869 static gfc_dependency
870 gfc_check_section_vs_section (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
891 /* If they are the same range, return without more ado. */
892 if (gfc_is_same_range (&l_ar
, &r_ar
, n
, 0))
893 return GFC_DEP_EQUAL
;
895 l_start
= l_ar
.start
[n
];
897 l_stride
= l_ar
.stride
[n
];
899 r_start
= r_ar
.start
[n
];
901 r_stride
= r_ar
.stride
[n
];
903 /* If l_start is NULL take it from array specifier. */
904 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
905 l_start
= l_ar
.as
->lower
[n
];
906 /* If l_end is NULL take it from array specifier. */
907 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
908 l_end
= l_ar
.as
->upper
[n
];
910 /* If r_start is NULL take it from array specifier. */
911 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
912 r_start
= r_ar
.as
->lower
[n
];
913 /* If r_end is NULL take it from array specifier. */
914 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
915 r_end
= r_ar
.as
->upper
[n
];
917 /* Determine whether the l_stride is positive or negative. */
920 else if (l_stride
->expr_type
== EXPR_CONSTANT
921 && l_stride
->ts
.type
== BT_INTEGER
)
922 l_dir
= mpz_sgn (l_stride
->value
.integer
);
923 else if (l_start
&& l_end
)
924 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
928 /* Determine whether the r_stride is positive or negative. */
931 else if (r_stride
->expr_type
== EXPR_CONSTANT
932 && r_stride
->ts
.type
== BT_INTEGER
)
933 r_dir
= mpz_sgn (r_stride
->value
.integer
);
934 else if (r_start
&& r_end
)
935 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
939 /* The strides should never be zero. */
940 if (l_dir
== 0 || r_dir
== 0)
941 return GFC_DEP_OVERLAP
;
943 /* Determine LHS upper and lower bounds. */
949 else if (l_dir
== -1)
960 /* Determine RHS upper and lower bounds. */
966 else if (r_dir
== -1)
977 /* Check whether the ranges are disjoint. */
978 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
979 return GFC_DEP_NODEP
;
980 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
981 return GFC_DEP_NODEP
;
983 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
984 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
986 if (l_dir
== 1 && r_dir
== -1)
987 return GFC_DEP_EQUAL
;
988 if (l_dir
== -1 && r_dir
== 1)
989 return GFC_DEP_EQUAL
;
992 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
993 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
995 if (l_dir
== 1 && r_dir
== -1)
996 return GFC_DEP_EQUAL
;
997 if (l_dir
== -1 && r_dir
== 1)
998 return GFC_DEP_EQUAL
;
1001 /* Check for forward dependencies x:y vs. x+1:z. */
1002 if (l_dir
== 1 && r_dir
== 1
1003 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == -1
1004 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == -1)
1006 /* Check that the strides are the same. */
1007 if (!l_stride
&& !r_stride
)
1008 return GFC_DEP_FORWARD
;
1009 if (l_stride
&& r_stride
1010 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
1011 return GFC_DEP_FORWARD
;
1014 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
1015 if (l_dir
== -1 && r_dir
== -1
1016 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 1
1017 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 1)
1019 /* Check that the strides are the same. */
1020 if (!l_stride
&& !r_stride
)
1021 return GFC_DEP_FORWARD
;
1022 if (l_stride
&& r_stride
1023 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
1024 return GFC_DEP_FORWARD
;
1027 return GFC_DEP_OVERLAP
;
1031 /* Determines overlapping for a single element and a section. */
1033 static gfc_dependency
1034 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1043 elem
= lref
->u
.ar
.start
[n
];
1045 return GFC_DEP_OVERLAP
;
1048 start
= ref
->start
[n
] ;
1050 stride
= ref
->stride
[n
];
1052 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1053 start
= ref
->as
->lower
[n
];
1054 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1055 end
= ref
->as
->upper
[n
];
1057 /* Determine whether the stride is positive or negative. */
1060 else if (stride
->expr_type
== EXPR_CONSTANT
1061 && stride
->ts
.type
== BT_INTEGER
)
1062 s
= mpz_sgn (stride
->value
.integer
);
1066 /* Stride should never be zero. */
1068 return GFC_DEP_OVERLAP
;
1070 /* Positive strides. */
1073 /* Check for elem < lower. */
1074 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1075 return GFC_DEP_NODEP
;
1076 /* Check for elem > upper. */
1077 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1078 return GFC_DEP_NODEP
;
1082 s
= gfc_dep_compare_expr (start
, end
);
1083 /* Check for an empty range. */
1085 return GFC_DEP_NODEP
;
1086 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1087 return GFC_DEP_EQUAL
;
1090 /* Negative strides. */
1093 /* Check for elem > upper. */
1094 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1095 return GFC_DEP_NODEP
;
1096 /* Check for elem < lower. */
1097 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1098 return GFC_DEP_NODEP
;
1102 s
= gfc_dep_compare_expr (start
, end
);
1103 /* Check for an empty range. */
1105 return GFC_DEP_NODEP
;
1106 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1107 return GFC_DEP_EQUAL
;
1110 /* Unknown strides. */
1114 return GFC_DEP_OVERLAP
;
1115 s
= gfc_dep_compare_expr (start
, end
);
1117 return GFC_DEP_OVERLAP
;
1118 /* Assume positive stride. */
1121 /* Check for elem < lower. */
1122 if (gfc_dep_compare_expr (elem
, start
) == -1)
1123 return GFC_DEP_NODEP
;
1124 /* Check for elem > upper. */
1125 if (gfc_dep_compare_expr (elem
, end
) == 1)
1126 return GFC_DEP_NODEP
;
1128 /* Assume negative stride. */
1131 /* Check for elem > upper. */
1132 if (gfc_dep_compare_expr (elem
, start
) == 1)
1133 return GFC_DEP_NODEP
;
1134 /* Check for elem < lower. */
1135 if (gfc_dep_compare_expr (elem
, end
) == -1)
1136 return GFC_DEP_NODEP
;
1141 s
= gfc_dep_compare_expr (elem
, start
);
1143 return GFC_DEP_EQUAL
;
1144 if (s
== 1 || s
== -1)
1145 return GFC_DEP_NODEP
;
1149 return GFC_DEP_OVERLAP
;
1153 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1154 forall_index attribute. Return true if any variable may be
1155 being used as a FORALL index. Its safe to pessimistically
1156 return true, and assume a dependency. */
1159 contains_forall_index_p (gfc_expr
*expr
)
1161 gfc_actual_arglist
*arg
;
1169 switch (expr
->expr_type
)
1172 if (expr
->symtree
->n
.sym
->forall_index
)
1177 if (contains_forall_index_p (expr
->value
.op
.op1
)
1178 || contains_forall_index_p (expr
->value
.op
.op2
))
1183 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1184 if (contains_forall_index_p (arg
->expr
))
1190 case EXPR_SUBSTRING
:
1193 case EXPR_STRUCTURE
:
1195 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1196 c
; gfc_constructor_next (c
))
1197 if (contains_forall_index_p (c
->expr
))
1205 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1209 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1210 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1211 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1212 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1220 if (contains_forall_index_p (ref
->u
.ss
.start
)
1221 || contains_forall_index_p (ref
->u
.ss
.end
))
1232 /* Determines overlapping for two single element array references. */
1234 static gfc_dependency
1235 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1245 l_start
= l_ar
.start
[n
] ;
1246 r_start
= r_ar
.start
[n
] ;
1247 i
= gfc_dep_compare_expr (r_start
, l_start
);
1249 return GFC_DEP_EQUAL
;
1251 /* Treat two scalar variables as potentially equal. This allows
1252 us to prove that a(i,:) and a(j,:) have no dependency. See
1253 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1254 Proceedings of the International Conference on Parallel and
1255 Distributed Processing Techniques and Applications (PDPTA2001),
1256 Las Vegas, Nevada, June 2001. */
1257 /* However, we need to be careful when either scalar expression
1258 contains a FORALL index, as these can potentially change value
1259 during the scalarization/traversal of this array reference. */
1260 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1261 return GFC_DEP_OVERLAP
;
1264 return GFC_DEP_NODEP
;
1265 return GFC_DEP_EQUAL
;
1269 /* Determine if an array ref, usually an array section specifies the
1270 entire array. In addition, if the second, pointer argument is
1271 provided, the function will return true if the reference is
1272 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1275 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1279 bool lbound_OK
= true;
1280 bool ubound_OK
= true;
1283 *contiguous
= false;
1285 if (ref
->type
!= REF_ARRAY
)
1288 if (ref
->u
.ar
.type
== AR_FULL
)
1295 if (ref
->u
.ar
.type
!= AR_SECTION
)
1300 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1302 /* If we have a single element in the reference, for the reference
1303 to be full, we need to ascertain that the array has a single
1304 element in this dimension and that we actually reference the
1306 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1308 /* This is unconditionally a contiguous reference if all the
1309 remaining dimensions are elements. */
1313 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1314 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1315 *contiguous
= false;
1319 || !ref
->u
.ar
.as
->lower
[i
]
1320 || !ref
->u
.ar
.as
->upper
[i
]
1321 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1322 ref
->u
.ar
.as
->upper
[i
])
1323 || !ref
->u
.ar
.start
[i
]
1324 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1325 ref
->u
.ar
.as
->lower
[i
]))
1331 /* Check the lower bound. */
1332 if (ref
->u
.ar
.start
[i
]
1334 || !ref
->u
.ar
.as
->lower
[i
]
1335 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1336 ref
->u
.ar
.as
->lower
[i
])))
1338 /* Check the upper bound. */
1339 if (ref
->u
.ar
.end
[i
]
1341 || !ref
->u
.ar
.as
->upper
[i
]
1342 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1343 ref
->u
.ar
.as
->upper
[i
])))
1345 /* Check the stride. */
1346 if (ref
->u
.ar
.stride
[i
]
1347 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1350 /* This is unconditionally a contiguous reference as long as all
1351 the subsequent dimensions are elements. */
1355 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1356 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1357 *contiguous
= false;
1360 if (!lbound_OK
|| !ubound_OK
)
1367 /* Determine if a full array is the same as an array section with one
1368 variable limit. For this to be so, the strides must both be unity
1369 and one of either start == lower or end == upper must be true. */
1372 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1375 bool upper_or_lower
;
1377 if (full_ref
->type
!= REF_ARRAY
)
1379 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1381 if (ref
->type
!= REF_ARRAY
)
1383 if (ref
->u
.ar
.type
!= AR_SECTION
)
1386 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1388 /* If we have a single element in the reference, we need to check
1389 that the array has a single element and that we actually reference
1390 the correct element. */
1391 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1393 if (!full_ref
->u
.ar
.as
1394 || !full_ref
->u
.ar
.as
->lower
[i
]
1395 || !full_ref
->u
.ar
.as
->upper
[i
]
1396 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1397 full_ref
->u
.ar
.as
->upper
[i
])
1398 || !ref
->u
.ar
.start
[i
]
1399 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1400 full_ref
->u
.ar
.as
->lower
[i
]))
1404 /* Check the strides. */
1405 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1407 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1410 upper_or_lower
= false;
1411 /* Check the lower bound. */
1412 if (ref
->u
.ar
.start
[i
]
1414 && full_ref
->u
.ar
.as
->lower
[i
]
1415 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1416 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
1417 upper_or_lower
= true;
1418 /* Check the upper bound. */
1419 if (ref
->u
.ar
.end
[i
]
1421 && full_ref
->u
.ar
.as
->upper
[i
]
1422 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1423 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
1424 upper_or_lower
= true;
1425 if (!upper_or_lower
)
1432 /* Finds if two array references are overlapping or not.
1434 1 : array references are overlapping.
1435 0 : array references are identical or not overlapping. */
1438 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
)
1441 gfc_dependency fin_dep
;
1442 gfc_dependency this_dep
;
1444 fin_dep
= GFC_DEP_ERROR
;
1445 /* Dependencies due to pointers should already have been identified.
1446 We only need to check for overlapping array references. */
1448 while (lref
&& rref
)
1450 /* We're resolving from the same base symbol, so both refs should be
1451 the same type. We traverse the reference chain until we find ranges
1452 that are not equal. */
1453 gcc_assert (lref
->type
== rref
->type
);
1457 /* The two ranges can't overlap if they are from different
1459 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1464 /* Substring overlaps are handled by the string assignment code
1465 if there is not an underlying dependency. */
1466 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1470 if (ref_same_as_full_array (lref
, rref
))
1473 if (ref_same_as_full_array (rref
, lref
))
1476 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1478 if (lref
->u
.ar
.type
== AR_FULL
)
1479 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
1481 else if (rref
->u
.ar
.type
== AR_FULL
)
1482 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
1489 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1491 /* Assume dependency when either of array reference is vector
1493 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1494 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1496 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1497 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1498 this_dep
= gfc_check_section_vs_section (lref
, rref
, n
);
1499 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1500 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1501 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1502 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1503 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1504 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1507 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1508 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1509 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1512 /* If any dimension doesn't overlap, we have no dependency. */
1513 if (this_dep
== GFC_DEP_NODEP
)
1516 /* Overlap codes are in order of priority. We only need to
1517 know the worst one.*/
1518 if (this_dep
> fin_dep
)
1522 /* If this is an equal element, we have to keep going until we find
1523 the "real" array reference. */
1524 if (lref
->u
.ar
.type
== AR_ELEMENT
1525 && rref
->u
.ar
.type
== AR_ELEMENT
1526 && fin_dep
== GFC_DEP_EQUAL
)
1529 /* Exactly matching and forward overlapping ranges don't cause a
1531 if (fin_dep
< GFC_DEP_OVERLAP
)
1534 /* Keep checking. We only have a dependency if
1535 subsequent references also overlap. */
1545 /* If we haven't seen any array refs then something went wrong. */
1546 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1548 /* Assume the worst if we nest to different depths. */
1552 return fin_dep
== GFC_DEP_OVERLAP
;