2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007
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"
31 /* static declarations */
33 enum range
{LHS
, RHS
, MID
};
35 /* Dependency types. These must be in reverse order of priority. */
39 GFC_DEP_EQUAL
, /* Identical Ranges. */
40 GFC_DEP_FORWARD
, /* eg. a(1:3), a(2:4). */
41 GFC_DEP_OVERLAP
, /* May overlap in some other way. */
42 GFC_DEP_NODEP
/* Distinct ranges. */
47 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
50 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
51 def if the value could not be determined. */
54 gfc_expr_is_one (gfc_expr
*expr
, int def
)
56 gcc_assert (expr
!= NULL
);
58 if (expr
->expr_type
!= EXPR_CONSTANT
)
61 if (expr
->ts
.type
!= BT_INTEGER
)
64 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
68 /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
69 and -2 if the relationship could not be determined. */
72 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
74 gfc_actual_arglist
*args1
;
75 gfc_actual_arglist
*args2
;
78 if (e1
->expr_type
== EXPR_OP
79 && (e1
->value
.op
.operator == INTRINSIC_UPLUS
80 || e1
->value
.op
.operator == INTRINSIC_PARENTHESES
))
81 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
82 if (e2
->expr_type
== EXPR_OP
83 && (e2
->value
.op
.operator == INTRINSIC_UPLUS
84 || e2
->value
.op
.operator == INTRINSIC_PARENTHESES
))
85 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
87 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.operator == INTRINSIC_PLUS
)
89 /* Compare X+C vs. X. */
90 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
91 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
92 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
93 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
95 /* Compare P+Q vs. R+S. */
96 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.operator == INTRINSIC_PLUS
)
100 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
101 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
102 if (l
== 0 && r
== 0)
104 if (l
== 0 && r
!= -2)
106 if (l
!= -2 && r
== 0)
108 if (l
== 1 && r
== 1)
110 if (l
== -1 && r
== -1)
113 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
114 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
115 if (l
== 0 && r
== 0)
117 if (l
== 0 && r
!= -2)
119 if (l
!= -2 && r
== 0)
121 if (l
== 1 && r
== 1)
123 if (l
== -1 && r
== -1)
128 /* Compare X vs. X+C. */
129 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.operator == INTRINSIC_PLUS
)
131 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
132 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
133 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
134 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
137 /* Compare X-C vs. X. */
138 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.operator == INTRINSIC_MINUS
)
140 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
141 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
142 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
143 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
145 /* Compare P-Q vs. R-S. */
146 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.operator == INTRINSIC_MINUS
)
150 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
151 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
152 if (l
== 0 && r
== 0)
154 if (l
!= -2 && r
== 0)
156 if (l
== 0 && r
!= -2)
158 if (l
== 1 && r
== -1)
160 if (l
== -1 && r
== 1)
165 /* Compare X vs. X-C. */
166 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.operator == INTRINSIC_MINUS
)
168 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
169 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
170 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
171 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
174 if (e1
->expr_type
!= e2
->expr_type
)
177 switch (e1
->expr_type
)
180 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
183 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
191 if (e1
->ref
|| e2
->ref
)
193 if (e1
->symtree
->n
.sym
== e2
->symtree
->n
.sym
)
198 /* Intrinsic operators are the same if their operands are the same. */
199 if (e1
->value
.op
.operator != e2
->value
.op
.operator)
201 if (e1
->value
.op
.op2
== 0)
203 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
204 return i
== 0 ? 0 : -2;
206 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
207 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
209 /* TODO Handle commutative binary operators here? */
213 /* We can only compare calls to the same intrinsic function. */
214 if (e1
->value
.function
.isym
== 0 || e2
->value
.function
.isym
== 0
215 || e1
->value
.function
.isym
!= e2
->value
.function
.isym
)
218 args1
= e1
->value
.function
.actual
;
219 args2
= e2
->value
.function
.actual
;
221 /* We should list the "constant" intrinsic functions. Those
222 without side-effects that provide equal results given equal
224 switch (e1
->value
.function
.isym
->id
)
226 case GFC_ISYM_CONVERSION
:
227 /* Handle integer extensions specially, as __convert_i4_i8
228 is not only "constant" but also "unary" and "increasing". */
229 if (args1
&& !args1
->next
230 && args2
&& !args2
->next
231 && e1
->ts
.type
== BT_INTEGER
232 && args1
->expr
->ts
.type
== BT_INTEGER
233 && e1
->ts
.kind
> args1
->expr
->ts
.kind
234 && e2
->ts
.type
== e1
->ts
.type
235 && e2
->ts
.kind
== e1
->ts
.kind
236 && args2
->expr
->ts
.type
== args1
->expr
->ts
.type
237 && args2
->expr
->ts
.kind
== args2
->expr
->ts
.kind
)
238 return gfc_dep_compare_expr (args1
->expr
, args2
->expr
);
242 case GFC_ISYM_LOGICAL
:
250 /* Compare the argument lists for equality. */
251 while (args1
&& args2
)
253 if (gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
258 return (args1
|| args2
) ? -2 : 0;
266 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
267 if the results are indeterminate. N is the dimension to compare. */
270 gfc_is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
, int def
)
276 /* TODO: More sophisticated range comparison. */
277 gcc_assert (ar1
&& ar2
);
279 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
283 /* Check for mismatching strides. A NULL stride means a stride of 1. */
286 i
= gfc_expr_is_one (e1
, -1);
294 i
= gfc_expr_is_one (e2
, -1);
302 i
= gfc_dep_compare_expr (e1
, e2
);
308 /* The strides match. */
310 /* Check the range start. */
315 /* Use the bound of the array if no bound is specified. */
317 e1
= ar1
->as
->lower
[n
];
320 e2
= ar2
->as
->lower
[n
];
322 /* Check we have values for both. */
326 i
= gfc_dep_compare_expr (e1
, e2
);
333 /* Check the range end. */
338 /* Use the bound of the array if no bound is specified. */
340 e1
= ar1
->as
->upper
[n
];
343 e2
= ar2
->as
->upper
[n
];
345 /* Check we have values for both. */
349 i
= gfc_dep_compare_expr (e1
, e2
);
360 /* Some array-returning intrinsics can be implemented by reusing the
361 data from one of the array arguments. For example, TRANSPOSE does
362 not necessarily need to allocate new data: it can be implemented
363 by copying the original array's descriptor and simply swapping the
364 two dimension specifications.
366 If EXPR is a call to such an intrinsic, return the argument
367 whose data can be reused, otherwise return NULL. */
370 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
372 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
375 switch (expr
->value
.function
.isym
->id
)
377 case GFC_ISYM_TRANSPOSE
:
378 return expr
->value
.function
.actual
->expr
;
386 /* Return true if the result of reference REF can only be constructed
387 using a temporary array. */
390 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
396 for (; ref
; ref
= ref
->next
)
400 /* Vector dimensions are generally not monotonic and must be
401 handled using a temporary. */
402 if (ref
->u
.ar
.type
== AR_SECTION
)
403 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
404 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
411 /* Within an array reference, character substrings generally
412 need a temporary. Character array strides are expressed as
413 multiples of the element size (consistent with other array
414 types), not in characters. */
425 /* Return true if array variable VAR could be passed to the same function
426 as argument EXPR without interfering with EXPR. INTENT is the intent
429 This is considerably less conservative than other dependencies
430 because many function arguments will already be copied into a
434 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
437 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
438 gcc_assert (var
->rank
> 0);
440 switch (expr
->expr_type
)
443 return (gfc_ref_needs_temporary_p (expr
->ref
)
444 || gfc_check_dependency (var
, expr
, 1));
447 return gfc_check_dependency (var
, expr
, 1);
450 if (intent
!= INTENT_IN
&& expr
->inline_noncopying_intrinsic
)
452 expr
= gfc_get_noncopying_intrinsic_argument (expr
);
453 return gfc_check_argument_var_dependency (var
, intent
, expr
);
463 /* Like gfc_check_argument_var_dependency, but extended to any
464 array expression OTHER, not just variables. */
467 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
470 switch (other
->expr_type
)
473 return gfc_check_argument_var_dependency (other
, intent
, expr
);
476 if (other
->inline_noncopying_intrinsic
)
478 other
= gfc_get_noncopying_intrinsic_argument (other
);
479 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
);
489 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
490 FNSYM is the function being called, or NULL if not known. */
493 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
494 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
)
496 gfc_formal_arglist
*formal
;
499 formal
= fnsym
? fnsym
->formal
: NULL
;
500 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
504 /* Skip args which are not present. */
508 /* Skip other itself. */
512 /* Skip intent(in) arguments if OTHER itself is intent(in). */
513 if (formal
&& intent
== INTENT_IN
514 && formal
->sym
->attr
.intent
== INTENT_IN
)
517 if (gfc_check_argument_dependency (other
, intent
, expr
))
525 /* Return 1 if e1 and e2 are equivalenced arrays, either
526 directly or indirectly; ie. equivalence (a,b) for a and b
527 or equivalence (a,c),(b,c). This function uses the equiv_
528 lists, generated in trans-common(add_equivalences), that are
529 guaranteed to pick up indirect equivalences. We explicitly
530 check for overlap using the offset and length of the equivalence.
531 This function is symmetric.
532 TODO: This function only checks whether the full top-level
533 symbols overlap. An improved implementation could inspect
534 e1->ref and e2->ref to determine whether the actually accessed
535 portions of these variables/arrays potentially overlap. */
538 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
541 gfc_equiv_info
*s
, *fl1
, *fl2
;
543 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
544 && e2
->expr_type
== EXPR_VARIABLE
);
546 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
547 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
550 /* Go through the equiv_lists and return 1 if the variables
551 e1 and e2 are members of the same group and satisfy the
552 requirement on their relative offsets. */
553 for (l
= gfc_current_ns
->equiv_lists
; l
; l
= l
->next
)
557 for (s
= l
->equiv
; s
; s
= s
->next
)
559 if (s
->sym
== e1
->symtree
->n
.sym
)
565 if (s
->sym
== e2
->symtree
->n
.sym
)
575 /* Can these lengths be zero? */
576 if (fl1
->length
<= 0 || fl2
->length
<= 0)
578 /* These can't overlap if [f11,fl1+length] is before
579 [fl2,fl2+length], or [fl2,fl2+length] is before
580 [fl1,fl1+length], otherwise they do overlap. */
581 if (fl1
->offset
+ fl1
->length
> fl2
->offset
582 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
590 /* Return true if the statement body redefines the condition. Returns
591 true if expr2 depends on expr1. expr1 should be a single term
592 suitable for the lhs of an assignment. The IDENTICAL flag indicates
593 whether array references to the same symbol with identical range
594 references count as a dependency or not. Used for forall and where
595 statements. Also used with functions returning arrays without a
599 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
601 gfc_actual_arglist
*actual
;
606 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
608 switch (expr2
->expr_type
)
611 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
614 if (expr2
->value
.op
.op2
)
615 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
619 /* The interesting cases are when the symbols don't match. */
620 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
622 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
623 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
625 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
626 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
629 /* Symbols can only alias if they have the same type. */
630 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
631 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
633 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
637 /* If either variable is a pointer, assume the worst. */
638 /* TODO: -fassume-no-pointer-aliasing */
639 if (expr1
->symtree
->n
.sym
->attr
.pointer
)
641 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
642 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
645 if (expr2
->symtree
->n
.sym
->attr
.pointer
)
647 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
648 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
651 /* Otherwise distinct symbols have no dependencies. */
658 /* Identical and disjoint ranges return 0,
659 overlapping ranges return 1. */
660 if (expr1
->ref
&& expr2
->ref
)
661 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
);
666 if (expr2
->inline_noncopying_intrinsic
)
668 /* Remember possible differences between elemental and
669 transformational functions. All functions inside a FORALL
671 for (actual
= expr2
->value
.function
.actual
;
672 actual
; actual
= actual
->next
)
676 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
687 /* Loop through the array constructor's elements. */
688 for (c
= expr2
->value
.constructor
; c
; c
= c
->next
)
690 /* If this is an iterator, assume the worst. */
693 /* Avoid recursion in the common case. */
694 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
696 if (gfc_check_dependency (expr1
, c
->expr
, 1))
707 /* Determines overlapping for two array sections. */
709 static gfc_dependency
710 gfc_check_section_vs_section (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
731 /* If they are the same range, return without more ado. */
732 if (gfc_is_same_range (&l_ar
, &r_ar
, n
, 0))
733 return GFC_DEP_EQUAL
;
735 l_start
= l_ar
.start
[n
];
737 l_stride
= l_ar
.stride
[n
];
739 r_start
= r_ar
.start
[n
];
741 r_stride
= r_ar
.stride
[n
];
743 /* If l_start is NULL take it from array specifier. */
744 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
745 l_start
= l_ar
.as
->lower
[n
];
746 /* If l_end is NULL take it from array specifier. */
747 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
748 l_end
= l_ar
.as
->upper
[n
];
750 /* If r_start is NULL take it from array specifier. */
751 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
752 r_start
= r_ar
.as
->lower
[n
];
753 /* If r_end is NULL take it from array specifier. */
754 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
755 r_end
= r_ar
.as
->upper
[n
];
757 /* Determine whether the l_stride is positive or negative. */
760 else if (l_stride
->expr_type
== EXPR_CONSTANT
761 && l_stride
->ts
.type
== BT_INTEGER
)
762 l_dir
= mpz_sgn (l_stride
->value
.integer
);
763 else if (l_start
&& l_end
)
764 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
768 /* Determine whether the r_stride is positive or negative. */
771 else if (r_stride
->expr_type
== EXPR_CONSTANT
772 && r_stride
->ts
.type
== BT_INTEGER
)
773 r_dir
= mpz_sgn (r_stride
->value
.integer
);
774 else if (r_start
&& r_end
)
775 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
779 /* The strides should never be zero. */
780 if (l_dir
== 0 || r_dir
== 0)
781 return GFC_DEP_OVERLAP
;
783 /* Determine LHS upper and lower bounds. */
789 else if (l_dir
== -1)
800 /* Determine RHS upper and lower bounds. */
806 else if (r_dir
== -1)
817 /* Check whether the ranges are disjoint. */
818 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
819 return GFC_DEP_NODEP
;
820 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
821 return GFC_DEP_NODEP
;
823 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
824 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
826 if (l_dir
== 1 && r_dir
== -1)
827 return GFC_DEP_EQUAL
;
828 if (l_dir
== -1 && r_dir
== 1)
829 return GFC_DEP_EQUAL
;
832 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
833 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
835 if (l_dir
== 1 && r_dir
== -1)
836 return GFC_DEP_EQUAL
;
837 if (l_dir
== -1 && r_dir
== 1)
838 return GFC_DEP_EQUAL
;
841 /* Check for forward dependencies x:y vs. x+1:z. */
842 if (l_dir
== 1 && r_dir
== 1
843 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == -1
844 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == -1)
846 /* Check that the strides are the same. */
847 if (!l_stride
&& !r_stride
)
848 return GFC_DEP_FORWARD
;
849 if (l_stride
&& r_stride
850 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
851 return GFC_DEP_FORWARD
;
854 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
855 if (l_dir
== -1 && r_dir
== -1
856 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 1
857 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 1)
859 /* Check that the strides are the same. */
860 if (!l_stride
&& !r_stride
)
861 return GFC_DEP_FORWARD
;
862 if (l_stride
&& r_stride
863 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
864 return GFC_DEP_FORWARD
;
867 return GFC_DEP_OVERLAP
;
871 /* Determines overlapping for a single element and a section. */
873 static gfc_dependency
874 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
883 elem
= lref
->u
.ar
.start
[n
];
885 return GFC_DEP_OVERLAP
;
888 start
= ref
->start
[n
] ;
890 stride
= ref
->stride
[n
];
892 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
893 start
= ref
->as
->lower
[n
];
894 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
895 end
= ref
->as
->upper
[n
];
897 /* Determine whether the stride is positive or negative. */
900 else if (stride
->expr_type
== EXPR_CONSTANT
901 && stride
->ts
.type
== BT_INTEGER
)
902 s
= mpz_sgn (stride
->value
.integer
);
906 /* Stride should never be zero. */
908 return GFC_DEP_OVERLAP
;
910 /* Positive strides. */
913 /* Check for elem < lower. */
914 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
915 return GFC_DEP_NODEP
;
916 /* Check for elem > upper. */
917 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
918 return GFC_DEP_NODEP
;
922 s
= gfc_dep_compare_expr (start
, end
);
923 /* Check for an empty range. */
925 return GFC_DEP_NODEP
;
926 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
927 return GFC_DEP_EQUAL
;
930 /* Negative strides. */
933 /* Check for elem > upper. */
934 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
935 return GFC_DEP_NODEP
;
936 /* Check for elem < lower. */
937 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
938 return GFC_DEP_NODEP
;
942 s
= gfc_dep_compare_expr (start
, end
);
943 /* Check for an empty range. */
945 return GFC_DEP_NODEP
;
946 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
947 return GFC_DEP_EQUAL
;
950 /* Unknown strides. */
954 return GFC_DEP_OVERLAP
;
955 s
= gfc_dep_compare_expr (start
, end
);
957 return GFC_DEP_OVERLAP
;
958 /* Assume positive stride. */
961 /* Check for elem < lower. */
962 if (gfc_dep_compare_expr (elem
, start
) == -1)
963 return GFC_DEP_NODEP
;
964 /* Check for elem > upper. */
965 if (gfc_dep_compare_expr (elem
, end
) == 1)
966 return GFC_DEP_NODEP
;
968 /* Assume negative stride. */
971 /* Check for elem > upper. */
972 if (gfc_dep_compare_expr (elem
, start
) == 1)
973 return GFC_DEP_NODEP
;
974 /* Check for elem < lower. */
975 if (gfc_dep_compare_expr (elem
, end
) == -1)
976 return GFC_DEP_NODEP
;
981 s
= gfc_dep_compare_expr (elem
, start
);
983 return GFC_DEP_EQUAL
;
984 if (s
== 1 || s
== -1)
985 return GFC_DEP_NODEP
;
989 return GFC_DEP_OVERLAP
;
993 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
994 forall_index attribute. Return true if any variable may be
995 being used as a FORALL index. Its safe to pessimistically
996 return true, and assume a dependency. */
999 contains_forall_index_p (gfc_expr
*expr
)
1001 gfc_actual_arglist
*arg
;
1009 switch (expr
->expr_type
)
1012 if (expr
->symtree
->n
.sym
->forall_index
)
1017 if (contains_forall_index_p (expr
->value
.op
.op1
)
1018 || contains_forall_index_p (expr
->value
.op
.op2
))
1023 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1024 if (contains_forall_index_p (arg
->expr
))
1030 case EXPR_SUBSTRING
:
1033 case EXPR_STRUCTURE
:
1035 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
1036 if (contains_forall_index_p (c
->expr
))
1044 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1048 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1049 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1050 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1051 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1059 if (contains_forall_index_p (ref
->u
.ss
.start
)
1060 || contains_forall_index_p (ref
->u
.ss
.end
))
1071 /* Determines overlapping for two single element array references. */
1073 static gfc_dependency
1074 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1084 l_start
= l_ar
.start
[n
] ;
1085 r_start
= r_ar
.start
[n
] ;
1086 i
= gfc_dep_compare_expr (r_start
, l_start
);
1088 return GFC_DEP_EQUAL
;
1090 /* Treat two scalar variables as potentially equal. This allows
1091 us to prove that a(i,:) and a(j,:) have no dependency. See
1092 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1093 Proceedings of the International Conference on Parallel and
1094 Distributed Processing Techniques and Applications (PDPTA2001),
1095 Las Vegas, Nevada, June 2001. */
1096 /* However, we need to be careful when either scalar expression
1097 contains a FORALL index, as these can potentially change value
1098 during the scalarization/traversal of this array reference. */
1099 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1100 return GFC_DEP_OVERLAP
;
1103 return GFC_DEP_NODEP
;
1104 return GFC_DEP_EQUAL
;
1108 /* Determine if an array ref, usually an array section specifies the
1112 gfc_full_array_ref_p (gfc_ref
*ref
)
1116 if (ref
->type
!= REF_ARRAY
)
1118 if (ref
->u
.ar
.type
== AR_FULL
)
1120 if (ref
->u
.ar
.type
!= AR_SECTION
)
1125 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1127 /* If we have a single element in the reference, we need to check
1128 that the array has a single element and that we actually reference
1129 the correct element. */
1130 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1133 || !ref
->u
.ar
.as
->lower
[i
]
1134 || !ref
->u
.ar
.as
->upper
[i
]
1135 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1136 ref
->u
.ar
.as
->upper
[i
])
1137 || !ref
->u
.ar
.start
[i
]
1138 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1139 ref
->u
.ar
.as
->lower
[i
]))
1145 /* Check the lower bound. */
1146 if (ref
->u
.ar
.start
[i
]
1148 || !ref
->u
.ar
.as
->lower
[i
]
1149 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1150 ref
->u
.ar
.as
->lower
[i
])))
1152 /* Check the upper bound. */
1153 if (ref
->u
.ar
.end
[i
]
1155 || !ref
->u
.ar
.as
->upper
[i
]
1156 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1157 ref
->u
.ar
.as
->upper
[i
])))
1159 /* Check the stride. */
1160 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1167 /* Finds if two array references are overlapping or not.
1169 1 : array references are overlapping.
1170 0 : array references are identical or not overlapping. */
1173 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
)
1176 gfc_dependency fin_dep
;
1177 gfc_dependency this_dep
;
1179 fin_dep
= GFC_DEP_ERROR
;
1180 /* Dependencies due to pointers should already have been identified.
1181 We only need to check for overlapping array references. */
1183 while (lref
&& rref
)
1185 /* We're resolving from the same base symbol, so both refs should be
1186 the same type. We traverse the reference chain intil we find ranges
1187 that are not equal. */
1188 gcc_assert (lref
->type
== rref
->type
);
1192 /* The two ranges can't overlap if they are from different
1194 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1199 /* Substring overlaps are handled by the string assignment code
1200 if there is not an underlying dependency. */
1201 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1204 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1206 if (lref
->u
.ar
.type
== AR_FULL
)
1207 fin_dep
= gfc_full_array_ref_p (rref
) ? GFC_DEP_EQUAL
1209 else if (rref
->u
.ar
.type
== AR_FULL
)
1210 fin_dep
= gfc_full_array_ref_p (lref
) ? GFC_DEP_EQUAL
1217 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1219 /* Assume dependency when either of array reference is vector
1221 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1222 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1224 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1225 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1226 this_dep
= gfc_check_section_vs_section (lref
, rref
, n
);
1227 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1228 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1229 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1230 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1231 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1232 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1235 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1236 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1237 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1240 /* If any dimension doesn't overlap, we have no dependency. */
1241 if (this_dep
== GFC_DEP_NODEP
)
1244 /* Overlap codes are in order of priority. We only need to
1245 know the worst one.*/
1246 if (this_dep
> fin_dep
)
1249 /* Exactly matching and forward overlapping ranges don't cause a
1251 if (fin_dep
< GFC_DEP_OVERLAP
)
1254 /* Keep checking. We only have a dependency if
1255 subsequent references also overlap. */
1265 /* If we haven't seen any array refs then something went wrong. */
1266 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1268 /* Assume the worst if we nest to different depths. */
1272 return fin_dep
== GFC_DEP_OVERLAP
;