2 Copyright (C) 2000, 2001, 2002, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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"
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
, /* eg. 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
.operator == INTRINSIC_UPLUS
81 || e1
->value
.op
.operator == INTRINSIC_PARENTHESES
))
82 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
83 if (e2
->expr_type
== EXPR_OP
84 && (e2
->value
.op
.operator == INTRINSIC_UPLUS
85 || e2
->value
.op
.operator == INTRINSIC_PARENTHESES
))
86 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
88 if (e1
->expr_type
== EXPR_OP
89 && e1
->value
.op
.operator == 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
99 && e2
->value
.op
.operator == INTRINSIC_PLUS
)
103 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
104 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
105 if (l
== 0 && r
== 0)
107 if (l
== 0 && r
!= -2)
109 if (l
!= -2 && r
== 0)
111 if (l
== 1 && r
== 1)
113 if (l
== -1 && r
== -1)
116 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
117 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
118 if (l
== 0 && r
== 0)
120 if (l
== 0 && r
!= -2)
122 if (l
!= -2 && r
== 0)
124 if (l
== 1 && r
== 1)
126 if (l
== -1 && r
== -1)
131 /* Compare X vs. X+C. */
132 if (e2
->expr_type
== EXPR_OP
133 && e2
->value
.op
.operator == INTRINSIC_PLUS
)
135 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
136 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
137 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
138 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
141 /* Compare X-C vs. X. */
142 if (e1
->expr_type
== EXPR_OP
143 && e1
->value
.op
.operator == INTRINSIC_MINUS
)
145 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
146 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
147 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
148 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
150 /* Compare P-Q vs. R-S. */
151 if (e2
->expr_type
== EXPR_OP
152 && e2
->value
.op
.operator == INTRINSIC_MINUS
)
156 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
157 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
158 if (l
== 0 && r
== 0)
160 if (l
!= -2 && r
== 0)
162 if (l
== 0 && r
!= -2)
164 if (l
== 1 && r
== -1)
166 if (l
== -1 && r
== 1)
171 /* Compare X vs. X-C. */
172 if (e2
->expr_type
== EXPR_OP
173 && e2
->value
.op
.operator == INTRINSIC_MINUS
)
175 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
176 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
177 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
178 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
181 if (e1
->expr_type
!= e2
->expr_type
)
184 switch (e1
->expr_type
)
187 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
190 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
198 if (e1
->ref
|| e2
->ref
)
200 if (e1
->symtree
->n
.sym
== e2
->symtree
->n
.sym
)
205 /* Intrinsic operators are the same if their operands are the same. */
206 if (e1
->value
.op
.operator != e2
->value
.op
.operator)
208 if (e1
->value
.op
.op2
== 0)
210 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
211 return i
== 0 ? 0 : -2;
213 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
214 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
216 /* TODO Handle commutative binary operators here? */
220 /* We can only compare calls to the same intrinsic function. */
221 if (e1
->value
.function
.isym
== 0
222 || e2
->value
.function
.isym
== 0
223 || e1
->value
.function
.isym
!= e2
->value
.function
.isym
)
226 args1
= e1
->value
.function
.actual
;
227 args2
= e2
->value
.function
.actual
;
229 /* We should list the "constant" intrinsic functions. Those
230 without side-effects that provide equal results given equal
232 switch (e1
->value
.function
.isym
->generic_id
)
234 case GFC_ISYM_CONVERSION
:
235 /* Handle integer extensions specially, as __convert_i4_i8
236 is not only "constant" but also "unary" and "increasing". */
237 if (args1
&& !args1
->next
238 && args2
&& !args2
->next
239 && e1
->ts
.type
== BT_INTEGER
240 && args1
->expr
->ts
.type
== BT_INTEGER
241 && e1
->ts
.kind
> args1
->expr
->ts
.kind
242 && e2
->ts
.type
== e1
->ts
.type
243 && e2
->ts
.kind
== e1
->ts
.kind
244 && args2
->expr
->ts
.type
== args1
->expr
->ts
.type
245 && args2
->expr
->ts
.kind
== args2
->expr
->ts
.kind
)
246 return gfc_dep_compare_expr (args1
->expr
, args2
->expr
);
250 case GFC_ISYM_LOGICAL
:
258 /* Compare the argument lists for equality. */
259 while (args1
&& args2
)
261 if (gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
266 return (args1
|| args2
) ? -2 : 0;
274 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
275 if the results are indeterminate. N is the dimension to compare. */
278 gfc_is_same_range (gfc_array_ref
* ar1
, gfc_array_ref
* ar2
, int n
, int def
)
284 /* TODO: More sophisticated range comparison. */
285 gcc_assert (ar1
&& ar2
);
287 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
291 /* Check for mismatching strides. A NULL stride means a stride of 1. */
294 i
= gfc_expr_is_one (e1
, -1);
302 i
= gfc_expr_is_one (e2
, -1);
310 i
= gfc_dep_compare_expr (e1
, e2
);
316 /* The strides match. */
318 /* Check the range start. */
323 /* Use the bound of the array if no bound is specified. */
325 e1
= ar1
->as
->lower
[n
];
328 e2
= ar2
->as
->lower
[n
];
330 /* Check we have values for both. */
334 i
= gfc_dep_compare_expr (e1
, e2
);
341 /* Check the range end. */
346 /* Use the bound of the array if no bound is specified. */
348 e1
= ar1
->as
->upper
[n
];
351 e2
= ar2
->as
->upper
[n
];
353 /* Check we have values for both. */
357 i
= gfc_dep_compare_expr (e1
, e2
);
368 /* Some array-returning intrinsics can be implemented by reusing the
369 data from one of the array arguments. For example, TRANSPOSE does
370 not necessarily need to allocate new data: it can be implemented
371 by copying the original array's descriptor and simply swapping the
372 two dimension specifications.
374 If EXPR is a call to such an intrinsic, return the argument
375 whose data can be reused, otherwise return NULL. */
378 gfc_get_noncopying_intrinsic_argument (gfc_expr
* expr
)
380 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
383 switch (expr
->value
.function
.isym
->generic_id
)
385 case GFC_ISYM_TRANSPOSE
:
386 return expr
->value
.function
.actual
->expr
;
394 /* Return true if the result of reference REF can only be constructed
395 using a temporary array. */
398 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
404 for (; ref
; ref
= ref
->next
)
408 /* Vector dimensions are generally not monotonic and must be
409 handled using a temporary. */
410 if (ref
->u
.ar
.type
== AR_SECTION
)
411 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
412 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
419 /* Within an array reference, character substrings generally
420 need a temporary. Character array strides are expressed as
421 multiples of the element size (consistent with other array
422 types), not in characters. */
433 /* Return true if array variable VAR could be passed to the same function
434 as argument EXPR without interfering with EXPR. INTENT is the intent
437 This is considerably less conservative than other dependencies
438 because many function arguments will already be copied into a
442 gfc_check_argument_var_dependency (gfc_expr
* var
, sym_intent intent
,
445 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
446 gcc_assert (var
->rank
> 0);
448 switch (expr
->expr_type
)
451 return (gfc_ref_needs_temporary_p (expr
->ref
)
452 || gfc_check_dependency (var
, expr
, 1));
455 return gfc_check_dependency (var
, expr
, 1);
458 if (intent
!= INTENT_IN
&& expr
->inline_noncopying_intrinsic
)
460 expr
= gfc_get_noncopying_intrinsic_argument (expr
);
461 return gfc_check_argument_var_dependency (var
, intent
, expr
);
471 /* Like gfc_check_argument_var_dependency, but extended to any
472 array expression OTHER, not just variables. */
475 gfc_check_argument_dependency (gfc_expr
* other
, sym_intent intent
,
478 switch (other
->expr_type
)
481 return gfc_check_argument_var_dependency (other
, intent
, expr
);
484 if (other
->inline_noncopying_intrinsic
)
486 other
= gfc_get_noncopying_intrinsic_argument (other
);
487 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
);
497 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
498 FNSYM is the function being called, or NULL if not known. */
501 gfc_check_fncall_dependency (gfc_expr
* other
, sym_intent intent
,
502 gfc_symbol
* fnsym
, gfc_actual_arglist
* actual
)
504 gfc_formal_arglist
*formal
;
507 formal
= fnsym
? fnsym
->formal
: NULL
;
508 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
512 /* Skip args which are not present. */
516 /* Skip other itself. */
520 /* Skip intent(in) arguments if OTHER itself is intent(in). */
522 && intent
== INTENT_IN
523 && formal
->sym
->attr
.intent
== INTENT_IN
)
526 if (gfc_check_argument_dependency (other
, intent
, expr
))
534 /* Return 1 if e1 and e2 are equivalenced arrays, either
535 directly or indirectly; ie. equivalence (a,b) for a and b
536 or equivalence (a,c),(b,c). This function uses the equiv_
537 lists, generated in trans-common(add_equivalences), that are
538 guaranteed to pick up indirect equivalences. We explicitly
539 check for overlap using the offset and length of the equivalence.
540 This function is symmetric.
541 TODO: This function only checks whether the full top-level
542 symbols overlap. An improved implementation could inspect
543 e1->ref and e2->ref to determine whether the actually accessed
544 portions of these variables/arrays potentially overlap. */
547 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
550 gfc_equiv_info
*s
, *fl1
, *fl2
;
552 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
553 && e2
->expr_type
== EXPR_VARIABLE
);
555 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
556 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
561 /* Go through the equiv_lists and return 1 if the variables
562 e1 and e2 are members of the same group and satisfy the
563 requirement on their relative offsets. */
564 for (l
= gfc_current_ns
->equiv_lists
; l
; l
= l
->next
)
568 for (s
= l
->equiv
; s
; s
= s
->next
)
570 if (s
->sym
== e1
->symtree
->n
.sym
)
576 if (s
->sym
== e2
->symtree
->n
.sym
)
586 /* Can these lengths be zero? */
587 if (fl1
->length
<= 0 || fl2
->length
<= 0)
589 /* These can't overlap if [f11,fl1+length] is before
590 [fl2,fl2+length], or [fl2,fl2+length] is before
591 [fl1,fl1+length], otherwise they do overlap. */
592 if (fl1
->offset
+ fl1
->length
> fl2
->offset
593 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
601 /* Return true if the statement body redefines the condition. Returns
602 true if expr2 depends on expr1. expr1 should be a single term
603 suitable for the lhs of an assignment. The IDENTICAL flag indicates
604 whether array references to the same symbol with identical range
605 references count as a dependency or not. Used for forall and where
606 statements. Also used with functions returning arrays without a
610 gfc_check_dependency (gfc_expr
* expr1
, gfc_expr
* expr2
, bool identical
)
614 gfc_actual_arglist
*actual
;
616 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
618 switch (expr2
->expr_type
)
621 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
624 if (expr2
->value
.op
.op2
)
625 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
629 /* The interesting cases are when the symbols don't match. */
630 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
632 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
633 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
635 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
636 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
639 /* Symbols can only alias if they have the same type. */
640 if (ts1
->type
!= BT_UNKNOWN
641 && ts2
->type
!= BT_UNKNOWN
642 && ts1
->type
!= BT_DERIVED
643 && ts2
->type
!= BT_DERIVED
)
645 if (ts1
->type
!= ts2
->type
646 || ts1
->kind
!= ts2
->kind
)
650 /* If either variable is a pointer, assume the worst. */
651 /* TODO: -fassume-no-pointer-aliasing */
652 if (expr1
->symtree
->n
.sym
->attr
.pointer
)
654 for (ref
= expr1
->ref
; ref
; ref
= ref
->next
)
655 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
658 if (expr2
->symtree
->n
.sym
->attr
.pointer
)
660 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
661 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->pointer
)
664 /* Otherwise distinct symbols have no dependencies. */
671 /* Identical and disjoint ranges return 0,
672 overlapping ranges return 1. */
673 /* Return zero if we refer to the same full arrays. */
674 if (expr1
->ref
->type
== REF_ARRAY
&& expr2
->ref
->type
== REF_ARRAY
)
675 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
);
680 if (expr2
->inline_noncopying_intrinsic
)
682 /* Remember possible differences between elemental and
683 transformational functions. All functions inside a FORALL
685 for (actual
= expr2
->value
.function
.actual
;
686 actual
; actual
= actual
->next
)
690 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
701 /* Probably ok in the majority of (constant) cases. */
710 /* Determines overlapping for two array sections. */
712 static gfc_dependency
713 gfc_check_section_vs_section (gfc_ref
* lref
, gfc_ref
* rref
, int n
)
734 /* If they are the same range, return without more ado. */
735 if (gfc_is_same_range (&l_ar
, &r_ar
, n
, 0))
736 return GFC_DEP_EQUAL
;
738 l_start
= l_ar
.start
[n
];
740 l_stride
= l_ar
.stride
[n
];
742 r_start
= r_ar
.start
[n
];
744 r_stride
= r_ar
.stride
[n
];
746 /* If l_start is NULL take it from array specifier. */
747 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
748 l_start
= l_ar
.as
->lower
[n
];
749 /* If l_end is NULL take it from array specifier. */
750 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
751 l_end
= l_ar
.as
->upper
[n
];
753 /* If r_start is NULL take it from array specifier. */
754 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
755 r_start
= r_ar
.as
->lower
[n
];
756 /* If r_end is NULL take it from array specifier. */
757 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
758 r_end
= r_ar
.as
->upper
[n
];
760 /* Determine whether the l_stride is positive or negative. */
763 else if (l_stride
->expr_type
== EXPR_CONSTANT
764 && l_stride
->ts
.type
== BT_INTEGER
)
765 l_dir
= mpz_sgn (l_stride
->value
.integer
);
766 else if (l_start
&& l_end
)
767 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
771 /* Determine whether the r_stride is positive or negative. */
774 else if (r_stride
->expr_type
== EXPR_CONSTANT
775 && r_stride
->ts
.type
== BT_INTEGER
)
776 r_dir
= mpz_sgn (r_stride
->value
.integer
);
777 else if (r_start
&& r_end
)
778 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
782 /* The strides should never be zero. */
783 if (l_dir
== 0 || r_dir
== 0)
784 return GFC_DEP_OVERLAP
;
786 /* Determine LHS upper and lower bounds. */
792 else if (l_dir
== -1)
803 /* Determine RHS upper and lower bounds. */
809 else if (r_dir
== -1)
820 /* Check whether the ranges are disjoint. */
821 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
822 return GFC_DEP_NODEP
;
823 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
824 return GFC_DEP_NODEP
;
826 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
827 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
829 if (l_dir
== 1 && r_dir
== -1)
830 return GFC_DEP_EQUAL
;
831 if (l_dir
== -1 && r_dir
== 1)
832 return GFC_DEP_EQUAL
;
835 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
836 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
838 if (l_dir
== 1 && r_dir
== -1)
839 return GFC_DEP_EQUAL
;
840 if (l_dir
== -1 && r_dir
== 1)
841 return GFC_DEP_EQUAL
;
844 /* Check for forward dependencies x:y vs. x+1:z. */
845 if (l_dir
== 1 && r_dir
== 1
846 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == -1
847 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == -1)
849 /* Check that the strides are the same. */
850 if (!l_stride
&& !r_stride
)
851 return GFC_DEP_FORWARD
;
852 if (l_stride
&& r_stride
853 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
854 return GFC_DEP_FORWARD
;
857 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
858 if (l_dir
== -1 && r_dir
== -1
859 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 1
860 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 1)
862 /* Check that the strides are the same. */
863 if (!l_stride
&& !r_stride
)
864 return GFC_DEP_FORWARD
;
865 if (l_stride
&& r_stride
866 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
867 return GFC_DEP_FORWARD
;
870 return GFC_DEP_OVERLAP
;
874 /* Determines overlapping for a single element and a section. */
876 static gfc_dependency
877 gfc_check_element_vs_section( gfc_ref
* lref
, gfc_ref
* rref
, int n
)
886 elem
= lref
->u
.ar
.start
[n
];
888 return GFC_DEP_OVERLAP
;
891 start
= ref
->start
[n
] ;
893 stride
= ref
->stride
[n
];
895 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
896 start
= ref
->as
->lower
[n
];
897 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
898 end
= ref
->as
->upper
[n
];
900 /* Determine whether the stride is positive or negative. */
903 else if (stride
->expr_type
== EXPR_CONSTANT
904 && stride
->ts
.type
== BT_INTEGER
)
905 s
= mpz_sgn (stride
->value
.integer
);
909 /* Stride should never be zero. */
911 return GFC_DEP_OVERLAP
;
913 /* Positive strides. */
916 /* Check for elem < lower. */
917 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
918 return GFC_DEP_NODEP
;
919 /* Check for elem > upper. */
920 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
921 return GFC_DEP_NODEP
;
925 s
= gfc_dep_compare_expr (start
, end
);
926 /* Check for an empty range. */
928 return GFC_DEP_NODEP
;
929 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
930 return GFC_DEP_EQUAL
;
933 /* Negative strides. */
936 /* Check for elem > upper. */
937 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
938 return GFC_DEP_NODEP
;
939 /* Check for elem < lower. */
940 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
941 return GFC_DEP_NODEP
;
945 s
= gfc_dep_compare_expr (start
, end
);
946 /* Check for an empty range. */
948 return GFC_DEP_NODEP
;
949 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
950 return GFC_DEP_EQUAL
;
953 /* Unknown strides. */
957 return GFC_DEP_OVERLAP
;
958 s
= gfc_dep_compare_expr (start
, end
);
960 return GFC_DEP_OVERLAP
;
961 /* Assume positive stride. */
964 /* Check for elem < lower. */
965 if (gfc_dep_compare_expr (elem
, start
) == -1)
966 return GFC_DEP_NODEP
;
967 /* Check for elem > upper. */
968 if (gfc_dep_compare_expr (elem
, end
) == 1)
969 return GFC_DEP_NODEP
;
971 /* Assume negative stride. */
974 /* Check for elem > upper. */
975 if (gfc_dep_compare_expr (elem
, start
) == 1)
976 return GFC_DEP_NODEP
;
977 /* Check for elem < lower. */
978 if (gfc_dep_compare_expr (elem
, end
) == -1)
979 return GFC_DEP_NODEP
;
984 s
= gfc_dep_compare_expr (elem
, start
);
986 return GFC_DEP_EQUAL
;
987 if (s
== 1 || s
== -1)
988 return GFC_DEP_NODEP
;
992 return GFC_DEP_OVERLAP
;
996 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
997 forall_index attribute. Return true if any variable may be
998 being used as a FORALL index. Its safe to pessimistically
999 return true, and assume a dependency. */
1002 contains_forall_index_p (gfc_expr
* expr
)
1004 gfc_actual_arglist
*arg
;
1012 switch (expr
->expr_type
)
1015 if (expr
->symtree
->n
.sym
->forall_index
)
1020 if (contains_forall_index_p (expr
->value
.op
.op1
)
1021 || contains_forall_index_p (expr
->value
.op
.op2
))
1026 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1027 if (contains_forall_index_p (arg
->expr
))
1033 case EXPR_SUBSTRING
:
1036 case EXPR_STRUCTURE
:
1038 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
1039 if (contains_forall_index_p (c
->expr
))
1047 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1051 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1052 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1053 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1054 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1062 if (contains_forall_index_p (ref
->u
.ss
.start
)
1063 || contains_forall_index_p (ref
->u
.ss
.end
))
1074 /* Determines overlapping for two single element array references. */
1076 static gfc_dependency
1077 gfc_check_element_vs_element (gfc_ref
* lref
, gfc_ref
* rref
, int n
)
1087 l_start
= l_ar
.start
[n
] ;
1088 r_start
= r_ar
.start
[n
] ;
1089 i
= gfc_dep_compare_expr (r_start
, l_start
);
1091 return GFC_DEP_EQUAL
;
1093 /* Treat two scalar variables as potentially equal. This allows
1094 us to prove that a(i,:) and a(j,:) have no dependency. See
1095 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1096 Proceedings of the International Conference on Parallel and
1097 Distributed Processing Techniques and Applications (PDPTA2001),
1098 Las Vegas, Nevada, June 2001. */
1099 /* However, we need to be careful when either scalar expression
1100 contains a FORALL index, as these can potentially change value
1101 during the scalarization/traversal of this array reference. */
1102 if (contains_forall_index_p (r_start
)
1103 || contains_forall_index_p (l_start
))
1104 return GFC_DEP_OVERLAP
;
1107 return GFC_DEP_NODEP
;
1108 return GFC_DEP_EQUAL
;
1112 /* Determine if an array ref, usually an array section specifies the
1116 gfc_full_array_ref_p (gfc_ref
*ref
)
1120 if (ref
->type
!= REF_ARRAY
)
1122 if (ref
->u
.ar
.type
== AR_FULL
)
1124 if (ref
->u
.ar
.type
!= AR_SECTION
)
1127 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1129 /* Check the lower bound. */
1130 if (ref
->u
.ar
.start
[i
]
1132 || !ref
->u
.ar
.as
->lower
[i
]
1133 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1134 ref
->u
.ar
.as
->lower
[i
])))
1136 /* Check the upper bound. */
1137 if (ref
->u
.ar
.end
[i
]
1139 || !ref
->u
.ar
.as
->upper
[i
]
1140 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1141 ref
->u
.ar
.as
->upper
[i
])))
1143 /* Check the stride. */
1144 if (ref
->u
.ar
.stride
[i
]
1145 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1152 /* Finds if two array references are overlapping or not.
1154 1 : array references are overlapping.
1155 0 : array references are identical or not overlapping. */
1158 gfc_dep_resolver (gfc_ref
* lref
, gfc_ref
* rref
)
1161 gfc_dependency fin_dep
;
1162 gfc_dependency this_dep
;
1165 fin_dep
= GFC_DEP_ERROR
;
1166 /* Dependencies due to pointers should already have been identified.
1167 We only need to check for overlapping array references. */
1169 while (lref
&& rref
)
1171 /* We're resolving from the same base symbol, so both refs should be
1172 the same type. We traverse the reference chain intil we find ranges
1173 that are not equal. */
1174 gcc_assert (lref
->type
== rref
->type
);
1178 /* The two ranges can't overlap if they are from different
1180 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1185 /* Substring overlaps are handled by the string assignment code. */
1189 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1191 if (lref
->u
.ar
.type
== AR_FULL
)
1192 fin_dep
= gfc_full_array_ref_p (rref
) ? GFC_DEP_EQUAL
1194 else if (rref
->u
.ar
.type
== AR_FULL
)
1195 fin_dep
= gfc_full_array_ref_p (lref
) ? GFC_DEP_EQUAL
1202 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1204 /* Assume dependency when either of array reference is vector
1206 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1207 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1209 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1210 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1211 this_dep
= gfc_check_section_vs_section (lref
, rref
, n
);
1212 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1213 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1214 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1215 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1216 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1217 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1220 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1221 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1222 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1225 /* If any dimension doesn't overlap, we have no dependency. */
1226 if (this_dep
== GFC_DEP_NODEP
)
1229 /* Overlap codes are in order of priority. We only need to
1230 know the worst one.*/
1231 if (this_dep
> fin_dep
)
1234 /* Exactly matching and forward overlapping ranges don't cause a
1236 if (fin_dep
< GFC_DEP_OVERLAP
)
1239 /* Keep checking. We only have a dependency if
1240 subsequent references also overlap. */
1250 /* If we haven't seen any array refs then something went wrong. */
1251 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1253 /* Assume the worst if we nest to different depths. */
1257 return fin_dep
== GFC_DEP_OVERLAP
;