2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* dependency.c -- Expression dependency analysis code. */
23 /* There's probably quite a bit of duplication in this file. We currently
24 have different dependency checking functions for different types
25 if dependencies. Ideally these would probably be merged. */
30 #include "dependency.h"
31 #include "constructor.h"
33 /* static declarations */
35 enum range
{LHS
, RHS
, MID
};
37 /* Dependency types. These must be in reverse order of priority. */
41 GFC_DEP_EQUAL
, /* Identical Ranges. */
42 GFC_DEP_FORWARD
, /* e.g., a(1:3) = a(2:4). */
43 GFC_DEP_BACKWARD
, /* e.g. a(2:4) = a(1:3). */
44 GFC_DEP_OVERLAP
, /* May overlap in some other way. */
45 GFC_DEP_NODEP
/* Distinct ranges. */
50 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
52 /* Forward declarations */
54 static gfc_dependency
check_section_vs_section (gfc_array_ref
*,
55 gfc_array_ref
*, int);
57 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
58 def if the value could not be determined. */
61 gfc_expr_is_one (gfc_expr
*expr
, int def
)
63 gcc_assert (expr
!= NULL
);
65 if (expr
->expr_type
!= EXPR_CONSTANT
)
68 if (expr
->ts
.type
!= BT_INTEGER
)
71 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
74 /* Check if two array references are known to be identical. Calls
75 gfc_dep_compare_expr if necessary for comparing array indices. */
78 identical_array_ref (gfc_array_ref
*a1
, gfc_array_ref
*a2
)
82 if (a1
->type
== AR_FULL
&& a2
->type
== AR_FULL
)
85 if (a1
->type
== AR_SECTION
&& a2
->type
== AR_SECTION
)
87 gcc_assert (a1
->dimen
== a2
->dimen
);
89 for ( i
= 0; i
< a1
->dimen
; i
++)
91 /* TODO: Currently, we punt on an integer array as an index. */
92 if (a1
->dimen_type
[i
] != DIMEN_RANGE
93 || a2
->dimen_type
[i
] != DIMEN_RANGE
)
96 if (check_section_vs_section (a1
, a2
, i
) != GFC_DEP_EQUAL
)
102 if (a1
->type
== AR_ELEMENT
&& a2
->type
== AR_ELEMENT
)
104 gcc_assert (a1
->dimen
== a2
->dimen
);
105 for (i
= 0; i
< a1
->dimen
; i
++)
107 if (gfc_dep_compare_expr (a1
->start
[i
], a2
->start
[i
]) != 0)
117 /* Return true for identical variables, checking for references if
118 necessary. Calls identical_array_ref for checking array sections. */
121 gfc_are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
125 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
131 while (r1
!= NULL
|| r2
!= NULL
)
134 /* Assume the variables are not equal if one has a reference and the
136 TODO: Handle full references like comparing a(:) to a.
139 if (r1
== NULL
|| r2
== NULL
)
142 if (r1
->type
!= r2
->type
)
149 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
155 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
160 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0
161 || gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
166 gfc_internal_error ("gfc_are_identical_variables: Bad type");
174 /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
175 and -2 if the relationship could not be determined. */
178 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
180 gfc_actual_arglist
*args1
;
181 gfc_actual_arglist
*args2
;
188 /* Remove any integer conversion functions to larger types. */
189 if (e1
->expr_type
== EXPR_FUNCTION
&& e1
->value
.function
.isym
190 && e1
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
191 && e1
->ts
.type
== BT_INTEGER
)
193 args1
= e1
->value
.function
.actual
;
194 if (args1
->expr
->ts
.type
== BT_INTEGER
195 && e1
->ts
.kind
> args1
->expr
->ts
.kind
)
199 if (e2
->expr_type
== EXPR_FUNCTION
&& e2
->value
.function
.isym
200 && e2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
201 && e2
->ts
.type
== BT_INTEGER
)
203 args2
= e2
->value
.function
.actual
;
204 if (args2
->expr
->ts
.type
== BT_INTEGER
205 && e2
->ts
.kind
> args2
->expr
->ts
.kind
)
212 return gfc_dep_compare_expr (n1
, n2
);
214 return gfc_dep_compare_expr (n1
, e2
);
219 return gfc_dep_compare_expr (e1
, n2
);
222 if (e1
->expr_type
== EXPR_OP
223 && (e1
->value
.op
.op
== INTRINSIC_UPLUS
224 || e1
->value
.op
.op
== INTRINSIC_PARENTHESES
))
225 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
226 if (e2
->expr_type
== EXPR_OP
227 && (e2
->value
.op
.op
== INTRINSIC_UPLUS
228 || e2
->value
.op
.op
== INTRINSIC_PARENTHESES
))
229 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
231 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
233 /* Compare X+C vs. X. */
234 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
235 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
236 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
237 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
239 /* Compare P+Q vs. R+S. */
240 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
244 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
245 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
246 if (l
== 0 && r
== 0)
248 if (l
== 0 && r
!= -2)
250 if (l
!= -2 && r
== 0)
252 if (l
== 1 && r
== 1)
254 if (l
== -1 && r
== -1)
257 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
258 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
259 if (l
== 0 && r
== 0)
261 if (l
== 0 && r
!= -2)
263 if (l
!= -2 && r
== 0)
265 if (l
== 1 && r
== 1)
267 if (l
== -1 && r
== -1)
272 /* Compare X vs. X+C. */
273 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
275 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
276 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
277 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
278 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
281 /* Compare X-C vs. X. */
282 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
284 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
285 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
286 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
287 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
289 /* Compare P-Q vs. R-S. */
290 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
294 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
295 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
296 if (l
== 0 && r
== 0)
298 if (l
!= -2 && r
== 0)
300 if (l
== 0 && r
!= -2)
302 if (l
== 1 && r
== -1)
304 if (l
== -1 && r
== 1)
309 /* Compare X vs. X-C. */
310 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
312 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
313 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
314 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
315 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
318 if (e1
->expr_type
!= e2
->expr_type
)
321 switch (e1
->expr_type
)
324 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
327 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
335 if (gfc_are_identical_variables (e1
, e2
))
341 /* Intrinsic operators are the same if their operands are the same. */
342 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
344 if (e1
->value
.op
.op2
== 0)
346 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
347 return i
== 0 ? 0 : -2;
349 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
350 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
352 /* TODO Handle commutative binary operators here? */
357 /* PURE functions can be compared for argument equality. */
358 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
359 && e1
->value
.function
.esym
== e2
->value
.function
.esym
360 && e1
->value
.function
.esym
->result
->attr
.pure
)
361 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
362 && e1
->value
.function
.isym
== e2
->value
.function
.isym
363 && e1
->value
.function
.isym
->pure
))
365 args1
= e1
->value
.function
.actual
;
366 args2
= e2
->value
.function
.actual
;
368 /* Compare the argument lists for equality. */
369 while (args1
&& args2
)
371 /* Bitwise xor, since C has no non-bitwise xor operator. */
372 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
375 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
376 && gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
382 return (args1
|| args2
) ? -2 : 0;
394 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
395 if the results are indeterminate. N is the dimension to compare. */
398 gfc_is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
, int def
)
404 /* TODO: More sophisticated range comparison. */
405 gcc_assert (ar1
&& ar2
);
407 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
411 /* Check for mismatching strides. A NULL stride means a stride of 1. */
414 i
= gfc_expr_is_one (e1
, -1);
422 i
= gfc_expr_is_one (e2
, -1);
430 i
= gfc_dep_compare_expr (e1
, e2
);
436 /* The strides match. */
438 /* Check the range start. */
443 /* Use the bound of the array if no bound is specified. */
445 e1
= ar1
->as
->lower
[n
];
448 e2
= ar2
->as
->lower
[n
];
450 /* Check we have values for both. */
454 i
= gfc_dep_compare_expr (e1
, e2
);
461 /* Check the range end. */
466 /* Use the bound of the array if no bound is specified. */
468 e1
= ar1
->as
->upper
[n
];
471 e2
= ar2
->as
->upper
[n
];
473 /* Check we have values for both. */
477 i
= gfc_dep_compare_expr (e1
, e2
);
488 /* Some array-returning intrinsics can be implemented by reusing the
489 data from one of the array arguments. For example, TRANSPOSE does
490 not necessarily need to allocate new data: it can be implemented
491 by copying the original array's descriptor and simply swapping the
492 two dimension specifications.
494 If EXPR is a call to such an intrinsic, return the argument
495 whose data can be reused, otherwise return NULL. */
498 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
500 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
503 switch (expr
->value
.function
.isym
->id
)
505 case GFC_ISYM_TRANSPOSE
:
506 return expr
->value
.function
.actual
->expr
;
514 /* Return true if the result of reference REF can only be constructed
515 using a temporary array. */
518 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
524 for (; ref
; ref
= ref
->next
)
528 /* Vector dimensions are generally not monotonic and must be
529 handled using a temporary. */
530 if (ref
->u
.ar
.type
== AR_SECTION
)
531 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
532 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
539 /* Within an array reference, character substrings generally
540 need a temporary. Character array strides are expressed as
541 multiples of the element size (consistent with other array
542 types), not in characters. */
554 gfc_is_data_pointer (gfc_expr
*e
)
558 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
561 /* No subreference if it is a function */
562 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
564 if (e
->symtree
->n
.sym
->attr
.pointer
)
567 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
568 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
575 /* Return true if array variable VAR could be passed to the same function
576 as argument EXPR without interfering with EXPR. INTENT is the intent
579 This is considerably less conservative than other dependencies
580 because many function arguments will already be copied into a
584 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
585 gfc_expr
*expr
, gfc_dep_check elemental
)
589 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
590 gcc_assert (var
->rank
> 0);
592 switch (expr
->expr_type
)
595 /* In case of elemental subroutines, there is no dependency
596 between two same-range array references. */
597 if (gfc_ref_needs_temporary_p (expr
->ref
)
598 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
600 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
602 /* Too many false positive with pointers. */
603 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
605 /* Elemental procedures forbid unspecified intents,
606 and we don't check dependencies for INTENT_IN args. */
607 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
609 /* We are told not to check dependencies.
610 We do it, however, and issue a warning in case we find one.
611 If a dependency is found in the case
612 elemental == ELEM_CHECK_VARIABLE, we will generate
613 a temporary, so we don't need to bother the user. */
614 gfc_warning ("INTENT(%s) actual argument at %L might "
615 "interfere with actual argument at %L.",
616 intent
== INTENT_OUT
? "OUT" : "INOUT",
617 &var
->where
, &expr
->where
);
627 return gfc_check_dependency (var
, expr
, 1);
630 if (intent
!= INTENT_IN
)
632 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
634 return gfc_check_argument_var_dependency (var
, intent
, arg
,
638 if (elemental
!= NOT_ELEMENTAL
)
640 if ((expr
->value
.function
.esym
641 && expr
->value
.function
.esym
->attr
.elemental
)
642 || (expr
->value
.function
.isym
643 && expr
->value
.function
.isym
->elemental
))
644 return gfc_check_fncall_dependency (var
, intent
, NULL
,
645 expr
->value
.function
.actual
,
646 ELEM_CHECK_VARIABLE
);
651 /* In case of non-elemental procedures, there is no need to catch
652 dependencies, as we will make a temporary anyway. */
655 /* If the actual arg EXPR is an expression, we need to catch
656 a dependency between variables in EXPR and VAR,
657 an intent((IN)OUT) variable. */
658 if (expr
->value
.op
.op1
659 && gfc_check_argument_var_dependency (var
, intent
,
661 ELEM_CHECK_VARIABLE
))
663 else if (expr
->value
.op
.op2
664 && gfc_check_argument_var_dependency (var
, intent
,
666 ELEM_CHECK_VARIABLE
))
677 /* Like gfc_check_argument_var_dependency, but extended to any
678 array expression OTHER, not just variables. */
681 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
682 gfc_expr
*expr
, gfc_dep_check elemental
)
684 switch (other
->expr_type
)
687 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
690 other
= gfc_get_noncopying_intrinsic_argument (other
);
692 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
703 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
704 FNSYM is the function being called, or NULL if not known. */
707 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
708 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
709 gfc_dep_check elemental
)
711 gfc_formal_arglist
*formal
;
714 formal
= fnsym
? fnsym
->formal
: NULL
;
715 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
719 /* Skip args which are not present. */
723 /* Skip other itself. */
727 /* Skip intent(in) arguments if OTHER itself is intent(in). */
728 if (formal
&& intent
== INTENT_IN
729 && formal
->sym
->attr
.intent
== INTENT_IN
)
732 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
740 /* Return 1 if e1 and e2 are equivalenced arrays, either
741 directly or indirectly; i.e., equivalence (a,b) for a and b
742 or equivalence (a,c),(b,c). This function uses the equiv_
743 lists, generated in trans-common(add_equivalences), that are
744 guaranteed to pick up indirect equivalences. We explicitly
745 check for overlap using the offset and length of the equivalence.
746 This function is symmetric.
747 TODO: This function only checks whether the full top-level
748 symbols overlap. An improved implementation could inspect
749 e1->ref and e2->ref to determine whether the actually accessed
750 portions of these variables/arrays potentially overlap. */
753 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
756 gfc_equiv_info
*s
, *fl1
, *fl2
;
758 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
759 && e2
->expr_type
== EXPR_VARIABLE
);
761 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
762 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
765 if (e1
->symtree
->n
.sym
->ns
766 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
767 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
769 l
= gfc_current_ns
->equiv_lists
;
771 /* Go through the equiv_lists and return 1 if the variables
772 e1 and e2 are members of the same group and satisfy the
773 requirement on their relative offsets. */
774 for (; l
; l
= l
->next
)
778 for (s
= l
->equiv
; s
; s
= s
->next
)
780 if (s
->sym
== e1
->symtree
->n
.sym
)
786 if (s
->sym
== e2
->symtree
->n
.sym
)
796 /* Can these lengths be zero? */
797 if (fl1
->length
<= 0 || fl2
->length
<= 0)
799 /* These can't overlap if [f11,fl1+length] is before
800 [fl2,fl2+length], or [fl2,fl2+length] is before
801 [fl1,fl1+length], otherwise they do overlap. */
802 if (fl1
->offset
+ fl1
->length
> fl2
->offset
803 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
811 /* Return true if there is no possibility of aliasing because of a type
812 mismatch between all the possible pointer references and the
813 potential target. Note that this function is asymmetric in the
814 arguments and so must be called twice with the arguments exchanged. */
817 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
823 bool seen_component_ref
;
825 if (expr1
->expr_type
!= EXPR_VARIABLE
826 || expr1
->expr_type
!= EXPR_VARIABLE
)
829 sym1
= expr1
->symtree
->n
.sym
;
830 sym2
= expr2
->symtree
->n
.sym
;
832 /* Keep it simple for now. */
833 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
836 if (sym1
->attr
.pointer
)
838 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
842 /* This is a conservative check on the components of the derived type
843 if no component references have been seen. Since we will not dig
844 into the components of derived type components, we play it safe by
845 returning false. First we check the reference chain and then, if
846 no component references have been seen, the components. */
847 seen_component_ref
= false;
848 if (sym1
->ts
.type
== BT_DERIVED
)
850 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
852 if (ref1
->type
!= REF_COMPONENT
)
855 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
858 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
859 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
862 seen_component_ref
= true;
866 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
868 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
870 if (cm1
->ts
.type
== BT_DERIVED
)
873 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
874 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
883 /* Return true if the statement body redefines the condition. Returns
884 true if expr2 depends on expr1. expr1 should be a single term
885 suitable for the lhs of an assignment. The IDENTICAL flag indicates
886 whether array references to the same symbol with identical range
887 references count as a dependency or not. Used for forall and where
888 statements. Also used with functions returning arrays without a
892 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
894 gfc_actual_arglist
*actual
;
898 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
900 switch (expr2
->expr_type
)
903 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
906 if (expr2
->value
.op
.op2
)
907 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
911 /* The interesting cases are when the symbols don't match. */
912 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
914 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
915 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
917 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
918 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
921 /* Symbols can only alias if they have the same type. */
922 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
923 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
925 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
929 /* If either variable is a pointer, assume the worst. */
930 /* TODO: -fassume-no-pointer-aliasing */
931 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
933 if (check_data_pointer_types (expr1
, expr2
)
934 && check_data_pointer_types (expr2
, expr1
))
941 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
942 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
943 if (sym1
->attr
.target
&& sym2
->attr
.target
944 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
945 && (!sym1
->attr
.dimension
946 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
947 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
948 && (!sym2
->attr
.dimension
949 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
953 /* Otherwise distinct symbols have no dependencies. */
960 /* Identical and disjoint ranges return 0,
961 overlapping ranges return 1. */
962 if (expr1
->ref
&& expr2
->ref
)
963 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
);
968 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
971 /* Remember possible differences between elemental and
972 transformational functions. All functions inside a FORALL
974 for (actual
= expr2
->value
.function
.actual
;
975 actual
; actual
= actual
->next
)
979 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
990 /* Loop through the array constructor's elements. */
991 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
992 c
; c
= gfc_constructor_next (c
))
994 /* If this is an iterator, assume the worst. */
997 /* Avoid recursion in the common case. */
998 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1000 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1011 /* Determines overlapping for two array sections. */
1013 static gfc_dependency
1014 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1029 bool identical_strides
;
1031 /* If they are the same range, return without more ado. */
1032 if (gfc_is_same_range (l_ar
, r_ar
, n
, 0))
1033 return GFC_DEP_EQUAL
;
1035 l_start
= l_ar
->start
[n
];
1036 l_end
= l_ar
->end
[n
];
1037 l_stride
= l_ar
->stride
[n
];
1039 r_start
= r_ar
->start
[n
];
1040 r_end
= r_ar
->end
[n
];
1041 r_stride
= r_ar
->stride
[n
];
1043 /* If l_start is NULL take it from array specifier. */
1044 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1045 l_start
= l_ar
->as
->lower
[n
];
1046 /* If l_end is NULL take it from array specifier. */
1047 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1048 l_end
= l_ar
->as
->upper
[n
];
1050 /* If r_start is NULL take it from array specifier. */
1051 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1052 r_start
= r_ar
->as
->lower
[n
];
1053 /* If r_end is NULL take it from array specifier. */
1054 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1055 r_end
= r_ar
->as
->upper
[n
];
1057 /* Determine whether the l_stride is positive or negative. */
1060 else if (l_stride
->expr_type
== EXPR_CONSTANT
1061 && l_stride
->ts
.type
== BT_INTEGER
)
1062 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1063 else if (l_start
&& l_end
)
1064 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1068 /* Determine whether the r_stride is positive or negative. */
1071 else if (r_stride
->expr_type
== EXPR_CONSTANT
1072 && r_stride
->ts
.type
== BT_INTEGER
)
1073 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1074 else if (r_start
&& r_end
)
1075 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1079 /* The strides should never be zero. */
1080 if (l_dir
== 0 || r_dir
== 0)
1081 return GFC_DEP_OVERLAP
;
1083 /* Determine if the strides are equal. */
1088 identical_strides
= gfc_dep_compare_expr (l_stride
, r_stride
) == 0;
1090 identical_strides
= gfc_expr_is_one (l_stride
, 0) == 1;
1095 identical_strides
= gfc_expr_is_one (r_stride
, 0) == 1;
1097 identical_strides
= true;
1100 /* Determine LHS upper and lower bounds. */
1106 else if (l_dir
== -1)
1117 /* Determine RHS upper and lower bounds. */
1123 else if (r_dir
== -1)
1134 /* Check whether the ranges are disjoint. */
1135 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1136 return GFC_DEP_NODEP
;
1137 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1138 return GFC_DEP_NODEP
;
1140 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1141 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1143 if (l_dir
== 1 && r_dir
== -1)
1144 return GFC_DEP_EQUAL
;
1145 if (l_dir
== -1 && r_dir
== 1)
1146 return GFC_DEP_EQUAL
;
1149 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1150 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1152 if (l_dir
== 1 && r_dir
== -1)
1153 return GFC_DEP_EQUAL
;
1154 if (l_dir
== -1 && r_dir
== 1)
1155 return GFC_DEP_EQUAL
;
1158 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1159 There is no dependency if the remainder of
1160 (l_start - r_start) / gcd(l_stride, r_stride) is
1163 - Handle cases where x is an expression.
1164 - Cases like a(1:4:2) = a(2:3) are still not handled.
1167 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1168 && (a)->ts.type == BT_INTEGER)
1170 if (IS_CONSTANT_INTEGER(l_start
) && IS_CONSTANT_INTEGER(r_start
)
1171 && IS_CONSTANT_INTEGER(l_stride
) && IS_CONSTANT_INTEGER(r_stride
))
1179 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1180 mpz_sub (tmp
, l_start
->value
.integer
, r_start
->value
.integer
);
1182 mpz_fdiv_r (tmp
, tmp
, gcd
);
1183 result
= mpz_cmp_si (tmp
, 0L);
1189 return GFC_DEP_NODEP
;
1192 #undef IS_CONSTANT_INTEGER
1194 /* Check for forward dependencies x:y vs. x+1:z. */
1195 if (l_dir
== 1 && r_dir
== 1
1196 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == -1
1197 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == -1)
1199 if (identical_strides
)
1200 return GFC_DEP_FORWARD
;
1203 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */
1204 if (l_dir
== -1 && r_dir
== -1
1205 && l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 1
1206 && l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 1)
1208 if (identical_strides
)
1209 return GFC_DEP_FORWARD
;
1213 if (identical_strides
)
1216 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1219 /* Check for a(low:y:s) vs. a(z:a:s) where a has a lower bound
1220 of low, which is always at least a forward dependence. */
1223 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1224 return GFC_DEP_FORWARD
;
1226 /* Check for a(high:y:-s) vs. a(z:a:-s) where a has a higher bound
1227 of high, which is always at least a forward dependence. */
1230 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1231 return GFC_DEP_FORWARD
;
1234 /* From here, check for backwards dependencies. */
1235 /* x:y vs. x+1:z. */
1236 if (l_dir
== 1 && r_dir
== 1
1237 && l_start
&& r_start
1238 && gfc_dep_compare_expr (l_start
, r_start
) == 1
1240 && gfc_dep_compare_expr (l_end
, r_end
) == 1)
1241 return GFC_DEP_BACKWARD
;
1243 /* x:y:-1 vs. x-1:z:-1. */
1244 if (l_dir
== -1 && r_dir
== -1
1245 && l_start
&& r_start
1246 && gfc_dep_compare_expr (l_start
, r_start
) == -1
1248 && gfc_dep_compare_expr (l_end
, r_end
) == -1)
1249 return GFC_DEP_BACKWARD
;
1252 return GFC_DEP_OVERLAP
;
1256 /* Determines overlapping for a single element and a section. */
1258 static gfc_dependency
1259 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1268 elem
= lref
->u
.ar
.start
[n
];
1270 return GFC_DEP_OVERLAP
;
1273 start
= ref
->start
[n
] ;
1275 stride
= ref
->stride
[n
];
1277 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1278 start
= ref
->as
->lower
[n
];
1279 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1280 end
= ref
->as
->upper
[n
];
1282 /* Determine whether the stride is positive or negative. */
1285 else if (stride
->expr_type
== EXPR_CONSTANT
1286 && stride
->ts
.type
== BT_INTEGER
)
1287 s
= mpz_sgn (stride
->value
.integer
);
1291 /* Stride should never be zero. */
1293 return GFC_DEP_OVERLAP
;
1295 /* Positive strides. */
1298 /* Check for elem < lower. */
1299 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1300 return GFC_DEP_NODEP
;
1301 /* Check for elem > upper. */
1302 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1303 return GFC_DEP_NODEP
;
1307 s
= gfc_dep_compare_expr (start
, end
);
1308 /* Check for an empty range. */
1310 return GFC_DEP_NODEP
;
1311 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1312 return GFC_DEP_EQUAL
;
1315 /* Negative strides. */
1318 /* Check for elem > upper. */
1319 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1320 return GFC_DEP_NODEP
;
1321 /* Check for elem < lower. */
1322 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1323 return GFC_DEP_NODEP
;
1327 s
= gfc_dep_compare_expr (start
, end
);
1328 /* Check for an empty range. */
1330 return GFC_DEP_NODEP
;
1331 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1332 return GFC_DEP_EQUAL
;
1335 /* Unknown strides. */
1339 return GFC_DEP_OVERLAP
;
1340 s
= gfc_dep_compare_expr (start
, end
);
1342 return GFC_DEP_OVERLAP
;
1343 /* Assume positive stride. */
1346 /* Check for elem < lower. */
1347 if (gfc_dep_compare_expr (elem
, start
) == -1)
1348 return GFC_DEP_NODEP
;
1349 /* Check for elem > upper. */
1350 if (gfc_dep_compare_expr (elem
, end
) == 1)
1351 return GFC_DEP_NODEP
;
1353 /* Assume negative stride. */
1356 /* Check for elem > upper. */
1357 if (gfc_dep_compare_expr (elem
, start
) == 1)
1358 return GFC_DEP_NODEP
;
1359 /* Check for elem < lower. */
1360 if (gfc_dep_compare_expr (elem
, end
) == -1)
1361 return GFC_DEP_NODEP
;
1366 s
= gfc_dep_compare_expr (elem
, start
);
1368 return GFC_DEP_EQUAL
;
1369 if (s
== 1 || s
== -1)
1370 return GFC_DEP_NODEP
;
1374 return GFC_DEP_OVERLAP
;
1378 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1379 forall_index attribute. Return true if any variable may be
1380 being used as a FORALL index. Its safe to pessimistically
1381 return true, and assume a dependency. */
1384 contains_forall_index_p (gfc_expr
*expr
)
1386 gfc_actual_arglist
*arg
;
1394 switch (expr
->expr_type
)
1397 if (expr
->symtree
->n
.sym
->forall_index
)
1402 if (contains_forall_index_p (expr
->value
.op
.op1
)
1403 || contains_forall_index_p (expr
->value
.op
.op2
))
1408 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1409 if (contains_forall_index_p (arg
->expr
))
1415 case EXPR_SUBSTRING
:
1418 case EXPR_STRUCTURE
:
1420 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1421 c
; gfc_constructor_next (c
))
1422 if (contains_forall_index_p (c
->expr
))
1430 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1434 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1435 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1436 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1437 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1445 if (contains_forall_index_p (ref
->u
.ss
.start
)
1446 || contains_forall_index_p (ref
->u
.ss
.end
))
1457 /* Determines overlapping for two single element array references. */
1459 static gfc_dependency
1460 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1470 l_start
= l_ar
.start
[n
] ;
1471 r_start
= r_ar
.start
[n
] ;
1472 i
= gfc_dep_compare_expr (r_start
, l_start
);
1474 return GFC_DEP_EQUAL
;
1476 /* Treat two scalar variables as potentially equal. This allows
1477 us to prove that a(i,:) and a(j,:) have no dependency. See
1478 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1479 Proceedings of the International Conference on Parallel and
1480 Distributed Processing Techniques and Applications (PDPTA2001),
1481 Las Vegas, Nevada, June 2001. */
1482 /* However, we need to be careful when either scalar expression
1483 contains a FORALL index, as these can potentially change value
1484 during the scalarization/traversal of this array reference. */
1485 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1486 return GFC_DEP_OVERLAP
;
1489 return GFC_DEP_NODEP
;
1490 return GFC_DEP_EQUAL
;
1494 /* Determine if an array ref, usually an array section specifies the
1495 entire array. In addition, if the second, pointer argument is
1496 provided, the function will return true if the reference is
1497 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1500 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1504 bool lbound_OK
= true;
1505 bool ubound_OK
= true;
1508 *contiguous
= false;
1510 if (ref
->type
!= REF_ARRAY
)
1513 if (ref
->u
.ar
.type
== AR_FULL
)
1520 if (ref
->u
.ar
.type
!= AR_SECTION
)
1525 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1527 /* If we have a single element in the reference, for the reference
1528 to be full, we need to ascertain that the array has a single
1529 element in this dimension and that we actually reference the
1531 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1533 /* This is unconditionally a contiguous reference if all the
1534 remaining dimensions are elements. */
1538 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1539 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1540 *contiguous
= false;
1544 || !ref
->u
.ar
.as
->lower
[i
]
1545 || !ref
->u
.ar
.as
->upper
[i
]
1546 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1547 ref
->u
.ar
.as
->upper
[i
])
1548 || !ref
->u
.ar
.start
[i
]
1549 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1550 ref
->u
.ar
.as
->lower
[i
]))
1556 /* Check the lower bound. */
1557 if (ref
->u
.ar
.start
[i
]
1559 || !ref
->u
.ar
.as
->lower
[i
]
1560 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1561 ref
->u
.ar
.as
->lower
[i
])))
1563 /* Check the upper bound. */
1564 if (ref
->u
.ar
.end
[i
]
1566 || !ref
->u
.ar
.as
->upper
[i
]
1567 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1568 ref
->u
.ar
.as
->upper
[i
])))
1570 /* Check the stride. */
1571 if (ref
->u
.ar
.stride
[i
]
1572 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1575 /* This is unconditionally a contiguous reference as long as all
1576 the subsequent dimensions are elements. */
1580 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1581 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1582 *contiguous
= false;
1585 if (!lbound_OK
|| !ubound_OK
)
1592 /* Determine if a full array is the same as an array section with one
1593 variable limit. For this to be so, the strides must both be unity
1594 and one of either start == lower or end == upper must be true. */
1597 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1600 bool upper_or_lower
;
1602 if (full_ref
->type
!= REF_ARRAY
)
1604 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1606 if (ref
->type
!= REF_ARRAY
)
1608 if (ref
->u
.ar
.type
!= AR_SECTION
)
1611 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1613 /* If we have a single element in the reference, we need to check
1614 that the array has a single element and that we actually reference
1615 the correct element. */
1616 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1618 if (!full_ref
->u
.ar
.as
1619 || !full_ref
->u
.ar
.as
->lower
[i
]
1620 || !full_ref
->u
.ar
.as
->upper
[i
]
1621 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1622 full_ref
->u
.ar
.as
->upper
[i
])
1623 || !ref
->u
.ar
.start
[i
]
1624 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1625 full_ref
->u
.ar
.as
->lower
[i
]))
1629 /* Check the strides. */
1630 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1632 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1635 upper_or_lower
= false;
1636 /* Check the lower bound. */
1637 if (ref
->u
.ar
.start
[i
]
1639 && full_ref
->u
.ar
.as
->lower
[i
]
1640 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1641 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
1642 upper_or_lower
= true;
1643 /* Check the upper bound. */
1644 if (ref
->u
.ar
.end
[i
]
1646 && full_ref
->u
.ar
.as
->upper
[i
]
1647 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1648 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
1649 upper_or_lower
= true;
1650 if (!upper_or_lower
)
1657 /* Finds if two array references are overlapping or not.
1659 2 : array references are overlapping but reversal of one or
1660 more dimensions will clear the dependency.
1661 1 : array references are overlapping.
1662 0 : array references are identical or not overlapping. */
1665 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
)
1668 gfc_dependency fin_dep
;
1669 gfc_dependency this_dep
;
1671 this_dep
= GFC_DEP_ERROR
;
1672 fin_dep
= GFC_DEP_ERROR
;
1673 /* Dependencies due to pointers should already have been identified.
1674 We only need to check for overlapping array references. */
1676 while (lref
&& rref
)
1678 /* We're resolving from the same base symbol, so both refs should be
1679 the same type. We traverse the reference chain until we find ranges
1680 that are not equal. */
1681 gcc_assert (lref
->type
== rref
->type
);
1685 /* The two ranges can't overlap if they are from different
1687 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1692 /* Substring overlaps are handled by the string assignment code
1693 if there is not an underlying dependency. */
1694 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1698 if (ref_same_as_full_array (lref
, rref
))
1701 if (ref_same_as_full_array (rref
, lref
))
1704 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1706 if (lref
->u
.ar
.type
== AR_FULL
)
1707 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
1709 else if (rref
->u
.ar
.type
== AR_FULL
)
1710 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
1717 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1719 /* Assume dependency when either of array reference is vector
1721 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1722 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1725 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1726 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1727 this_dep
= check_section_vs_section (&lref
->u
.ar
, &rref
->u
.ar
, n
);
1728 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1729 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1730 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1731 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1732 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1733 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1736 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1737 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1738 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1741 /* If any dimension doesn't overlap, we have no dependency. */
1742 if (this_dep
== GFC_DEP_NODEP
)
1745 /* Now deal with the loop reversal logic: This only works on
1746 ranges and is activated by setting
1747 reverse[n] == GFC_CAN_REVERSE
1748 The ability to reverse or not is set by previous conditions
1749 in this dimension. If reversal is not activated, the
1750 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
1751 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1752 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1754 /* Set reverse if backward dependence and not inhibited. */
1755 if (reverse
&& reverse
[n
] != GFC_CANNOT_REVERSE
)
1756 reverse
[n
] = (this_dep
== GFC_DEP_BACKWARD
) ?
1757 GFC_REVERSE_SET
: reverse
[n
];
1759 /* Inhibit loop reversal if dependence not compatible. */
1760 if (reverse
&& reverse
[n
] != GFC_REVERSE_NOT_SET
1761 && this_dep
!= GFC_DEP_EQUAL
1762 && this_dep
!= GFC_DEP_BACKWARD
1763 && this_dep
!= GFC_DEP_NODEP
)
1765 reverse
[n
] = GFC_CANNOT_REVERSE
;
1766 if (this_dep
!= GFC_DEP_FORWARD
)
1767 this_dep
= GFC_DEP_OVERLAP
;
1770 /* If no intention of reversing or reversing is explicitly
1771 inhibited, convert backward dependence to overlap. */
1772 if (this_dep
== GFC_DEP_BACKWARD
1773 && (reverse
== NULL
|| reverse
[n
] == GFC_CANNOT_REVERSE
))
1774 this_dep
= GFC_DEP_OVERLAP
;
1777 /* Overlap codes are in order of priority. We only need to
1778 know the worst one.*/
1779 if (this_dep
> fin_dep
)
1783 /* If this is an equal element, we have to keep going until we find
1784 the "real" array reference. */
1785 if (lref
->u
.ar
.type
== AR_ELEMENT
1786 && rref
->u
.ar
.type
== AR_ELEMENT
1787 && fin_dep
== GFC_DEP_EQUAL
)
1790 /* Exactly matching and forward overlapping ranges don't cause a
1792 if (fin_dep
< GFC_DEP_BACKWARD
)
1795 /* Keep checking. We only have a dependency if
1796 subsequent references also overlap. */
1806 /* If we haven't seen any array refs then something went wrong. */
1807 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1809 /* Assume the worst if we nest to different depths. */
1813 return fin_dep
== GFC_DEP_OVERLAP
;