2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009
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
, /* e.g., 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
.op
== INTRINSIC_UPLUS
80 || e1
->value
.op
.op
== INTRINSIC_PARENTHESES
))
81 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
82 if (e2
->expr_type
== EXPR_OP
83 && (e2
->value
.op
.op
== INTRINSIC_UPLUS
84 || e2
->value
.op
.op
== INTRINSIC_PARENTHESES
))
85 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
87 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== 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
.op
== 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
.op
== 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
.op
== 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
.op
== 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
.op
== 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
.op
!= e2
->value
.op
.op
)
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. */
426 gfc_is_data_pointer (gfc_expr
*e
)
430 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
433 /* No subreference if it is a function */
434 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
436 if (e
->symtree
->n
.sym
->attr
.pointer
)
439 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
440 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
447 /* Return true if array variable VAR could be passed to the same function
448 as argument EXPR without interfering with EXPR. INTENT is the intent
451 This is considerably less conservative than other dependencies
452 because many function arguments will already be copied into a
456 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
457 gfc_expr
*expr
, gfc_dep_check elemental
)
461 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
462 gcc_assert (var
->rank
> 0);
464 switch (expr
->expr_type
)
467 /* In case of elemental subroutines, there is no dependency
468 between two same-range array references. */
469 if (gfc_ref_needs_temporary_p (expr
->ref
)
470 || gfc_check_dependency (var
, expr
, !elemental
))
472 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
474 /* Too many false positive with pointers. */
475 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
477 /* Elemental procedures forbid unspecified intents,
478 and we don't check dependencies for INTENT_IN args. */
479 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
481 /* We are told not to check dependencies.
482 We do it, however, and issue a warning in case we find one.
483 If a dependency is found in the case
484 elemental == ELEM_CHECK_VARIABLE, we will generate
485 a temporary, so we don't need to bother the user. */
486 gfc_warning ("INTENT(%s) actual argument at %L might "
487 "interfere with actual argument at %L.",
488 intent
== INTENT_OUT
? "OUT" : "INOUT",
489 &var
->where
, &expr
->where
);
499 return gfc_check_dependency (var
, expr
, 1);
502 if (intent
!= INTENT_IN
&& expr
->inline_noncopying_intrinsic
503 && (arg
= gfc_get_noncopying_intrinsic_argument (expr
))
504 && gfc_check_argument_var_dependency (var
, intent
, arg
, elemental
))
508 if ((expr
->value
.function
.esym
509 && expr
->value
.function
.esym
->attr
.elemental
)
510 || (expr
->value
.function
.isym
511 && expr
->value
.function
.isym
->elemental
))
512 return gfc_check_fncall_dependency (var
, intent
, NULL
,
513 expr
->value
.function
.actual
,
514 ELEM_CHECK_VARIABLE
);
519 /* In case of non-elemental procedures, there is no need to catch
520 dependencies, as we will make a temporary anyway. */
523 /* If the actual arg EXPR is an expression, we need to catch
524 a dependency between variables in EXPR and VAR,
525 an intent((IN)OUT) variable. */
526 if (expr
->value
.op
.op1
527 && gfc_check_argument_var_dependency (var
, intent
,
529 ELEM_CHECK_VARIABLE
))
531 else if (expr
->value
.op
.op2
532 && gfc_check_argument_var_dependency (var
, intent
,
534 ELEM_CHECK_VARIABLE
))
545 /* Like gfc_check_argument_var_dependency, but extended to any
546 array expression OTHER, not just variables. */
549 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
550 gfc_expr
*expr
, gfc_dep_check elemental
)
552 switch (other
->expr_type
)
555 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
558 if (other
->inline_noncopying_intrinsic
)
560 other
= gfc_get_noncopying_intrinsic_argument (other
);
561 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
572 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
573 FNSYM is the function being called, or NULL if not known. */
576 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
577 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
578 gfc_dep_check elemental
)
580 gfc_formal_arglist
*formal
;
583 formal
= fnsym
? fnsym
->formal
: NULL
;
584 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
588 /* Skip args which are not present. */
592 /* Skip other itself. */
596 /* Skip intent(in) arguments if OTHER itself is intent(in). */
597 if (formal
&& intent
== INTENT_IN
598 && formal
->sym
->attr
.intent
== INTENT_IN
)
601 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
609 /* Return 1 if e1 and e2 are equivalenced arrays, either
610 directly or indirectly; i.e., equivalence (a,b) for a and b
611 or equivalence (a,c),(b,c). This function uses the equiv_
612 lists, generated in trans-common(add_equivalences), that are
613 guaranteed to pick up indirect equivalences. We explicitly
614 check for overlap using the offset and length of the equivalence.
615 This function is symmetric.
616 TODO: This function only checks whether the full top-level
617 symbols overlap. An improved implementation could inspect
618 e1->ref and e2->ref to determine whether the actually accessed
619 portions of these variables/arrays potentially overlap. */
622 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
625 gfc_equiv_info
*s
, *fl1
, *fl2
;
627 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
628 && e2
->expr_type
== EXPR_VARIABLE
);
630 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
631 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
634 if (e1
->symtree
->n
.sym
->ns
635 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
636 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
638 l
= gfc_current_ns
->equiv_lists
;
640 /* Go through the equiv_lists and return 1 if the variables
641 e1 and e2 are members of the same group and satisfy the
642 requirement on their relative offsets. */
643 for (; l
; l
= l
->next
)
647 for (s
= l
->equiv
; s
; s
= s
->next
)
649 if (s
->sym
== e1
->symtree
->n
.sym
)
655 if (s
->sym
== e2
->symtree
->n
.sym
)
665 /* Can these lengths be zero? */
666 if (fl1
->length
<= 0 || fl2
->length
<= 0)
668 /* These can't overlap if [f11,fl1+length] is before
669 [fl2,fl2+length], or [fl2,fl2+length] is before
670 [fl1,fl1+length], otherwise they do overlap. */
671 if (fl1
->offset
+ fl1
->length
> fl2
->offset
672 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
680 /* Return true if the statement body redefines the condition. Returns
681 true if expr2 depends on expr1. expr1 should be a single term
682 suitable for the lhs of an assignment. The IDENTICAL flag indicates
683 whether array references to the same symbol with identical range
684 references count as a dependency or not. Used for forall and where
685 statements. Also used with functions returning arrays without a
689 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
691 gfc_actual_arglist
*actual
;
695 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
697 switch (expr2
->expr_type
)
700 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
703 if (expr2
->value
.op
.op2
)
704 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
708 /* The interesting cases are when the symbols don't match. */
709 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
711 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
712 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
714 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
715 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
718 /* Symbols can only alias if they have the same type. */
719 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
720 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
722 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
726 /* If either variable is a pointer, assume the worst. */
727 /* TODO: -fassume-no-pointer-aliasing */
728 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
731 /* Otherwise distinct symbols have no dependencies. */
738 /* Identical and disjoint ranges return 0,
739 overlapping ranges return 1. */
740 if (expr1
->ref
&& expr2
->ref
)
741 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
);
746 if (expr2
->inline_noncopying_intrinsic
)
748 /* Remember possible differences between elemental and
749 transformational functions. All functions inside a FORALL
751 for (actual
= expr2
->value
.function
.actual
;
752 actual
; actual
= actual
->next
)
756 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
767 /* Loop through the array constructor's elements. */
768 for (c
= expr2
->value
.constructor
; c
; c
= c
->next
)
770 /* If this is an iterator, assume the worst. */
773 /* Avoid recursion in the common case. */
774 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
776 if (gfc_check_dependency (expr1
, c
->expr
, 1))
787 /* Determines overlapping for two array sections. */
789 static gfc_dependency
790 gfc_check_section_vs_section (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
811 /* If they are the same range, return without more ado. */
812 if (gfc_is_same_range (&l_ar
, &r_ar
, n
, 0))
813 return GFC_DEP_EQUAL
;
815 l_start
= l_ar
.start
[n
];
817 l_stride
= l_ar
.stride
[n
];
819 r_start
= r_ar
.start
[n
];
821 r_stride
= r_ar
.stride
[n
];
823 /* If l_start is NULL take it from array specifier. */
824 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
825 l_start
= l_ar
.as
->lower
[n
];
826 /* If l_end is NULL take it from array specifier. */
827 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
.as
))
828 l_end
= l_ar
.as
->upper
[n
];
830 /* If r_start is NULL take it from array specifier. */
831 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
832 r_start
= r_ar
.as
->lower
[n
];
833 /* If r_end is NULL take it from array specifier. */
834 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
.as
))
835 r_end
= r_ar
.as
->upper
[n
];
837 /* Determine whether the l_stride is positive or negative. */
840 else if (l_stride
->expr_type
== EXPR_CONSTANT
841 && l_stride
->ts
.type
== BT_INTEGER
)
842 l_dir
= mpz_sgn (l_stride
->value
.integer
);
843 else if (l_start
&& l_end
)
844 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
848 /* Determine whether the r_stride is positive or negative. */
851 else if (r_stride
->expr_type
== EXPR_CONSTANT
852 && r_stride
->ts
.type
== BT_INTEGER
)
853 r_dir
= mpz_sgn (r_stride
->value
.integer
);
854 else if (r_start
&& r_end
)
855 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
859 /* The strides should never be zero. */
860 if (l_dir
== 0 || r_dir
== 0)
861 return GFC_DEP_OVERLAP
;
863 /* Determine LHS upper and lower bounds. */
869 else if (l_dir
== -1)
880 /* Determine RHS upper and lower bounds. */
886 else if (r_dir
== -1)
897 /* Check whether the ranges are disjoint. */
898 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
899 return GFC_DEP_NODEP
;
900 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
901 return GFC_DEP_NODEP
;
903 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
904 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
906 if (l_dir
== 1 && r_dir
== -1)
907 return GFC_DEP_EQUAL
;
908 if (l_dir
== -1 && r_dir
== 1)
909 return GFC_DEP_EQUAL
;
912 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
913 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
915 if (l_dir
== 1 && r_dir
== -1)
916 return GFC_DEP_EQUAL
;
917 if (l_dir
== -1 && r_dir
== 1)
918 return GFC_DEP_EQUAL
;
921 /* Check for forward dependencies x:y vs. x+1:z. */
922 if (l_dir
== 1 && r_dir
== 1
923 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == -1
924 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == -1)
926 /* Check that the strides are the same. */
927 if (!l_stride
&& !r_stride
)
928 return GFC_DEP_FORWARD
;
929 if (l_stride
&& r_stride
930 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
931 return GFC_DEP_FORWARD
;
934 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
935 if (l_dir
== -1 && r_dir
== -1
936 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 1
937 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 1)
939 /* Check that the strides are the same. */
940 if (!l_stride
&& !r_stride
)
941 return GFC_DEP_FORWARD
;
942 if (l_stride
&& r_stride
943 && gfc_dep_compare_expr (l_stride
, r_stride
) == 0)
944 return GFC_DEP_FORWARD
;
947 return GFC_DEP_OVERLAP
;
951 /* Determines overlapping for a single element and a section. */
953 static gfc_dependency
954 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
963 elem
= lref
->u
.ar
.start
[n
];
965 return GFC_DEP_OVERLAP
;
968 start
= ref
->start
[n
] ;
970 stride
= ref
->stride
[n
];
972 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
973 start
= ref
->as
->lower
[n
];
974 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
975 end
= ref
->as
->upper
[n
];
977 /* Determine whether the stride is positive or negative. */
980 else if (stride
->expr_type
== EXPR_CONSTANT
981 && stride
->ts
.type
== BT_INTEGER
)
982 s
= mpz_sgn (stride
->value
.integer
);
986 /* Stride should never be zero. */
988 return GFC_DEP_OVERLAP
;
990 /* Positive strides. */
993 /* Check for elem < lower. */
994 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
995 return GFC_DEP_NODEP
;
996 /* Check for elem > upper. */
997 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
998 return GFC_DEP_NODEP
;
1002 s
= gfc_dep_compare_expr (start
, end
);
1003 /* Check for an empty range. */
1005 return GFC_DEP_NODEP
;
1006 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1007 return GFC_DEP_EQUAL
;
1010 /* Negative strides. */
1013 /* Check for elem > upper. */
1014 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1015 return GFC_DEP_NODEP
;
1016 /* Check for elem < lower. */
1017 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1018 return GFC_DEP_NODEP
;
1022 s
= gfc_dep_compare_expr (start
, end
);
1023 /* Check for an empty range. */
1025 return GFC_DEP_NODEP
;
1026 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1027 return GFC_DEP_EQUAL
;
1030 /* Unknown strides. */
1034 return GFC_DEP_OVERLAP
;
1035 s
= gfc_dep_compare_expr (start
, end
);
1037 return GFC_DEP_OVERLAP
;
1038 /* Assume positive stride. */
1041 /* Check for elem < lower. */
1042 if (gfc_dep_compare_expr (elem
, start
) == -1)
1043 return GFC_DEP_NODEP
;
1044 /* Check for elem > upper. */
1045 if (gfc_dep_compare_expr (elem
, end
) == 1)
1046 return GFC_DEP_NODEP
;
1048 /* Assume negative stride. */
1051 /* Check for elem > upper. */
1052 if (gfc_dep_compare_expr (elem
, start
) == 1)
1053 return GFC_DEP_NODEP
;
1054 /* Check for elem < lower. */
1055 if (gfc_dep_compare_expr (elem
, end
) == -1)
1056 return GFC_DEP_NODEP
;
1061 s
= gfc_dep_compare_expr (elem
, start
);
1063 return GFC_DEP_EQUAL
;
1064 if (s
== 1 || s
== -1)
1065 return GFC_DEP_NODEP
;
1069 return GFC_DEP_OVERLAP
;
1073 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1074 forall_index attribute. Return true if any variable may be
1075 being used as a FORALL index. Its safe to pessimistically
1076 return true, and assume a dependency. */
1079 contains_forall_index_p (gfc_expr
*expr
)
1081 gfc_actual_arglist
*arg
;
1089 switch (expr
->expr_type
)
1092 if (expr
->symtree
->n
.sym
->forall_index
)
1097 if (contains_forall_index_p (expr
->value
.op
.op1
)
1098 || contains_forall_index_p (expr
->value
.op
.op2
))
1103 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1104 if (contains_forall_index_p (arg
->expr
))
1110 case EXPR_SUBSTRING
:
1113 case EXPR_STRUCTURE
:
1115 for (c
= expr
->value
.constructor
; c
; c
= c
->next
)
1116 if (contains_forall_index_p (c
->expr
))
1124 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1128 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1129 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1130 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1131 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1139 if (contains_forall_index_p (ref
->u
.ss
.start
)
1140 || contains_forall_index_p (ref
->u
.ss
.end
))
1151 /* Determines overlapping for two single element array references. */
1153 static gfc_dependency
1154 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1164 l_start
= l_ar
.start
[n
] ;
1165 r_start
= r_ar
.start
[n
] ;
1166 i
= gfc_dep_compare_expr (r_start
, l_start
);
1168 return GFC_DEP_EQUAL
;
1170 /* Treat two scalar variables as potentially equal. This allows
1171 us to prove that a(i,:) and a(j,:) have no dependency. See
1172 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1173 Proceedings of the International Conference on Parallel and
1174 Distributed Processing Techniques and Applications (PDPTA2001),
1175 Las Vegas, Nevada, June 2001. */
1176 /* However, we need to be careful when either scalar expression
1177 contains a FORALL index, as these can potentially change value
1178 during the scalarization/traversal of this array reference. */
1179 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1180 return GFC_DEP_OVERLAP
;
1183 return GFC_DEP_NODEP
;
1184 return GFC_DEP_EQUAL
;
1188 /* Determine if an array ref, usually an array section specifies the
1189 entire array. In addition, if the second, pointer argument is
1190 provided, the function will return true if the reference is
1191 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1194 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1197 bool lbound_OK
= true;
1198 bool ubound_OK
= true;
1200 if (ref
->type
!= REF_ARRAY
)
1202 if (ref
->u
.ar
.type
== AR_FULL
)
1204 if (ref
->u
.ar
.type
!= AR_SECTION
)
1209 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1211 /* If we have a single element in the reference, we need to check
1212 that the array has a single element and that we actually reference
1213 the correct element. */
1214 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1216 /* This is a contiguous reference. */
1218 *contiguous
= (i
+ 1 == ref
->u
.ar
.dimen
);
1221 || !ref
->u
.ar
.as
->lower
[i
]
1222 || !ref
->u
.ar
.as
->upper
[i
]
1223 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1224 ref
->u
.ar
.as
->upper
[i
])
1225 || !ref
->u
.ar
.start
[i
]
1226 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1227 ref
->u
.ar
.as
->lower
[i
]))
1233 /* Check the lower bound. */
1234 if (ref
->u
.ar
.start
[i
]
1236 || !ref
->u
.ar
.as
->lower
[i
]
1237 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1238 ref
->u
.ar
.as
->lower
[i
])))
1240 /* Check the upper bound. */
1241 if (ref
->u
.ar
.end
[i
]
1243 || !ref
->u
.ar
.as
->upper
[i
]
1244 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1245 ref
->u
.ar
.as
->upper
[i
])))
1247 /* Check the stride. */
1248 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1251 /* This is a contiguous reference. */
1253 *contiguous
= (i
+ 1 == ref
->u
.ar
.dimen
);
1255 if (!lbound_OK
|| !ubound_OK
)
1262 /* Determine if a full array is the same as an array section with one
1263 variable limit. For this to be so, the strides must both be unity
1264 and one of either start == lower or end == upper must be true. */
1267 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1270 bool upper_or_lower
;
1272 if (full_ref
->type
!= REF_ARRAY
)
1274 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1276 if (ref
->type
!= REF_ARRAY
)
1278 if (ref
->u
.ar
.type
!= AR_SECTION
)
1281 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1283 /* If we have a single element in the reference, we need to check
1284 that the array has a single element and that we actually reference
1285 the correct element. */
1286 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1288 if (!full_ref
->u
.ar
.as
1289 || !full_ref
->u
.ar
.as
->lower
[i
]
1290 || !full_ref
->u
.ar
.as
->upper
[i
]
1291 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1292 full_ref
->u
.ar
.as
->upper
[i
])
1293 || !ref
->u
.ar
.start
[i
]
1294 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1295 full_ref
->u
.ar
.as
->lower
[i
]))
1299 /* Check the strides. */
1300 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1302 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1305 upper_or_lower
= false;
1306 /* Check the lower bound. */
1307 if (ref
->u
.ar
.start
[i
]
1309 && full_ref
->u
.ar
.as
->lower
[i
]
1310 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1311 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
1312 upper_or_lower
= true;
1313 /* Check the upper bound. */
1314 if (ref
->u
.ar
.end
[i
]
1316 && full_ref
->u
.ar
.as
->upper
[i
]
1317 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1318 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
1319 upper_or_lower
= true;
1320 if (!upper_or_lower
)
1327 /* Finds if two array references are overlapping or not.
1329 1 : array references are overlapping.
1330 0 : array references are identical or not overlapping. */
1333 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
)
1336 gfc_dependency fin_dep
;
1337 gfc_dependency this_dep
;
1339 fin_dep
= GFC_DEP_ERROR
;
1340 /* Dependencies due to pointers should already have been identified.
1341 We only need to check for overlapping array references. */
1343 while (lref
&& rref
)
1345 /* We're resolving from the same base symbol, so both refs should be
1346 the same type. We traverse the reference chain until we find ranges
1347 that are not equal. */
1348 gcc_assert (lref
->type
== rref
->type
);
1352 /* The two ranges can't overlap if they are from different
1354 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1359 /* Substring overlaps are handled by the string assignment code
1360 if there is not an underlying dependency. */
1361 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1365 if (ref_same_as_full_array (lref
, rref
))
1368 if (ref_same_as_full_array (rref
, lref
))
1371 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1373 if (lref
->u
.ar
.type
== AR_FULL
)
1374 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
1376 else if (rref
->u
.ar
.type
== AR_FULL
)
1377 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
1384 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1386 /* Assume dependency when either of array reference is vector
1388 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1389 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1391 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1392 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1393 this_dep
= gfc_check_section_vs_section (lref
, rref
, n
);
1394 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1395 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1396 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1397 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1398 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1399 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1402 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1403 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1404 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1407 /* If any dimension doesn't overlap, we have no dependency. */
1408 if (this_dep
== GFC_DEP_NODEP
)
1411 /* Overlap codes are in order of priority. We only need to
1412 know the worst one.*/
1413 if (this_dep
> fin_dep
)
1417 /* If this is an equal element, we have to keep going until we find
1418 the "real" array reference. */
1419 if (lref
->u
.ar
.type
== AR_ELEMENT
1420 && rref
->u
.ar
.type
== AR_ELEMENT
1421 && fin_dep
== GFC_DEP_EQUAL
)
1424 /* Exactly matching and forward overlapping ranges don't cause a
1426 if (fin_dep
< GFC_DEP_OVERLAP
)
1429 /* Keep checking. We only have a dependency if
1430 subsequent references also overlap. */
1440 /* If we haven't seen any array refs then something went wrong. */
1441 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1443 /* Assume the worst if we nest to different depths. */
1447 return fin_dep
== GFC_DEP_OVERLAP
;