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"
34 /* static declarations */
36 enum range
{LHS
, RHS
, MID
};
38 /* Dependency types. These must be in reverse order of priority. */
42 GFC_DEP_EQUAL
, /* Identical Ranges. */
43 GFC_DEP_FORWARD
, /* e.g., a(1:3) = a(2:4). */
44 GFC_DEP_BACKWARD
, /* e.g. a(2:4) = a(1:3). */
45 GFC_DEP_OVERLAP
, /* May overlap in some other way. */
46 GFC_DEP_NODEP
/* Distinct ranges. */
51 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
53 /* Forward declarations */
55 static gfc_dependency
check_section_vs_section (gfc_array_ref
*,
56 gfc_array_ref
*, int);
58 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
59 def if the value could not be determined. */
62 gfc_expr_is_one (gfc_expr
*expr
, int def
)
64 gcc_assert (expr
!= NULL
);
66 if (expr
->expr_type
!= EXPR_CONSTANT
)
69 if (expr
->ts
.type
!= BT_INTEGER
)
72 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
75 /* Check if two array references are known to be identical. Calls
76 gfc_dep_compare_expr if necessary for comparing array indices. */
79 identical_array_ref (gfc_array_ref
*a1
, gfc_array_ref
*a2
)
83 if (a1
->type
== AR_FULL
&& a2
->type
== AR_FULL
)
86 if (a1
->type
== AR_SECTION
&& a2
->type
== AR_SECTION
)
88 gcc_assert (a1
->dimen
== a2
->dimen
);
90 for ( i
= 0; i
< a1
->dimen
; i
++)
92 /* TODO: Currently, we punt on an integer array as an index. */
93 if (a1
->dimen_type
[i
] != DIMEN_RANGE
94 || a2
->dimen_type
[i
] != DIMEN_RANGE
)
97 if (check_section_vs_section (a1
, a2
, i
) != GFC_DEP_EQUAL
)
103 if (a1
->type
== AR_ELEMENT
&& a2
->type
== AR_ELEMENT
)
105 gcc_assert (a1
->dimen
== a2
->dimen
);
106 for (i
= 0; i
< a1
->dimen
; i
++)
108 if (gfc_dep_compare_expr (a1
->start
[i
], a2
->start
[i
]) != 0)
118 /* Return true for identical variables, checking for references if
119 necessary. Calls identical_array_ref for checking array sections. */
122 gfc_are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
126 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
129 /* Volatile variables should never compare equal to themselves. */
131 if (e1
->symtree
->n
.sym
->attr
.volatile_
)
137 while (r1
!= NULL
|| r2
!= NULL
)
140 /* Assume the variables are not equal if one has a reference and the
142 TODO: Handle full references like comparing a(:) to a.
145 if (r1
== NULL
|| r2
== NULL
)
148 if (r1
->type
!= r2
->type
)
155 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
161 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
166 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0
167 || gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
172 gfc_internal_error ("gfc_are_identical_variables: Bad type");
180 /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
181 and -2 if the relationship could not be determined. */
184 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
186 gfc_actual_arglist
*args1
;
187 gfc_actual_arglist
*args2
;
194 /* Remove any integer conversion functions to larger types. */
195 if (e1
->expr_type
== EXPR_FUNCTION
&& e1
->value
.function
.isym
196 && e1
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
197 && e1
->ts
.type
== BT_INTEGER
)
199 args1
= e1
->value
.function
.actual
;
200 if (args1
->expr
->ts
.type
== BT_INTEGER
201 && e1
->ts
.kind
> args1
->expr
->ts
.kind
)
205 if (e2
->expr_type
== EXPR_FUNCTION
&& e2
->value
.function
.isym
206 && e2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
207 && e2
->ts
.type
== BT_INTEGER
)
209 args2
= e2
->value
.function
.actual
;
210 if (args2
->expr
->ts
.type
== BT_INTEGER
211 && e2
->ts
.kind
> args2
->expr
->ts
.kind
)
218 return gfc_dep_compare_expr (n1
, n2
);
220 return gfc_dep_compare_expr (n1
, e2
);
225 return gfc_dep_compare_expr (e1
, n2
);
228 if (e1
->expr_type
== EXPR_OP
229 && (e1
->value
.op
.op
== INTRINSIC_UPLUS
230 || e1
->value
.op
.op
== INTRINSIC_PARENTHESES
))
231 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
232 if (e2
->expr_type
== EXPR_OP
233 && (e2
->value
.op
.op
== INTRINSIC_UPLUS
234 || e2
->value
.op
.op
== INTRINSIC_PARENTHESES
))
235 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
237 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
239 /* Compare X+C vs. X. */
240 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
241 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
242 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
243 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
245 /* Compare P+Q vs. R+S. */
246 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
250 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
251 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
252 if (l
== 0 && r
== 0)
254 if (l
== 0 && r
!= -2)
256 if (l
!= -2 && r
== 0)
258 if (l
== 1 && r
== 1)
260 if (l
== -1 && r
== -1)
263 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
264 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
265 if (l
== 0 && r
== 0)
267 if (l
== 0 && r
!= -2)
269 if (l
!= -2 && r
== 0)
271 if (l
== 1 && r
== 1)
273 if (l
== -1 && r
== -1)
278 /* Compare X vs. X+C. */
279 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
281 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
282 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
283 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
284 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
287 /* Compare X-C vs. X. */
288 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
290 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
291 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
292 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
293 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
295 /* Compare P-Q vs. R-S. */
296 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
300 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
301 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
302 if (l
== 0 && r
== 0)
304 if (l
!= -2 && r
== 0)
306 if (l
== 0 && r
!= -2)
308 if (l
== 1 && r
== -1)
310 if (l
== -1 && r
== 1)
315 /* Compare A // B vs. C // D. */
317 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_CONCAT
318 && e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_CONCAT
)
322 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
323 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
330 /* Watch out for 'A ' // x vs. 'A' // x. */
331 gfc_expr
*e1_left
= e1
->value
.op
.op1
;
332 gfc_expr
*e2_left
= e2
->value
.op
.op1
;
334 if (e1_left
->expr_type
== EXPR_CONSTANT
335 && e2_left
->expr_type
== EXPR_CONSTANT
336 && e1_left
->value
.character
.length
337 != e2_left
->value
.character
.length
)
351 /* Compare X vs. X-C. */
352 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
354 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
355 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
356 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
357 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
360 if (e1
->expr_type
!= e2
->expr_type
)
363 switch (e1
->expr_type
)
366 /* Compare strings for equality. */
367 if (e1
->ts
.type
== BT_CHARACTER
&& e2
->ts
.type
== BT_CHARACTER
)
368 return gfc_compare_string (e1
, e2
);
370 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
373 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
381 if (gfc_are_identical_variables (e1
, e2
))
387 /* Intrinsic operators are the same if their operands are the same. */
388 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
390 if (e1
->value
.op
.op2
== 0)
392 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
393 return i
== 0 ? 0 : -2;
395 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
396 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
398 /* TODO Handle commutative binary operators here? */
403 /* PURE functions can be compared for argument equality. */
404 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
405 && e1
->value
.function
.esym
== e2
->value
.function
.esym
406 && e1
->value
.function
.esym
->result
->attr
.pure
)
407 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
408 && e1
->value
.function
.isym
== e2
->value
.function
.isym
409 && e1
->value
.function
.isym
->pure
))
411 args1
= e1
->value
.function
.actual
;
412 args2
= e2
->value
.function
.actual
;
414 /* Compare the argument lists for equality. */
415 while (args1
&& args2
)
417 /* Bitwise xor, since C has no non-bitwise xor operator. */
418 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
421 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
422 && gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
428 return (args1
|| args2
) ? -2 : 0;
440 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
441 if the results are indeterminate. N is the dimension to compare. */
444 gfc_is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
, int def
)
450 /* TODO: More sophisticated range comparison. */
451 gcc_assert (ar1
&& ar2
);
453 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
457 /* Check for mismatching strides. A NULL stride means a stride of 1. */
460 i
= gfc_expr_is_one (e1
, -1);
468 i
= gfc_expr_is_one (e2
, -1);
476 i
= gfc_dep_compare_expr (e1
, e2
);
482 /* The strides match. */
484 /* Check the range start. */
489 /* Use the bound of the array if no bound is specified. */
491 e1
= ar1
->as
->lower
[n
];
494 e2
= ar2
->as
->lower
[n
];
496 /* Check we have values for both. */
500 i
= gfc_dep_compare_expr (e1
, e2
);
507 /* Check the range end. */
512 /* Use the bound of the array if no bound is specified. */
514 e1
= ar1
->as
->upper
[n
];
517 e2
= ar2
->as
->upper
[n
];
519 /* Check we have values for both. */
523 i
= gfc_dep_compare_expr (e1
, e2
);
534 /* Some array-returning intrinsics can be implemented by reusing the
535 data from one of the array arguments. For example, TRANSPOSE does
536 not necessarily need to allocate new data: it can be implemented
537 by copying the original array's descriptor and simply swapping the
538 two dimension specifications.
540 If EXPR is a call to such an intrinsic, return the argument
541 whose data can be reused, otherwise return NULL. */
544 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
546 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
549 switch (expr
->value
.function
.isym
->id
)
551 case GFC_ISYM_TRANSPOSE
:
552 return expr
->value
.function
.actual
->expr
;
560 /* Return true if the result of reference REF can only be constructed
561 using a temporary array. */
564 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
570 for (; ref
; ref
= ref
->next
)
574 /* Vector dimensions are generally not monotonic and must be
575 handled using a temporary. */
576 if (ref
->u
.ar
.type
== AR_SECTION
)
577 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
578 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
585 /* Within an array reference, character substrings generally
586 need a temporary. Character array strides are expressed as
587 multiples of the element size (consistent with other array
588 types), not in characters. */
600 gfc_is_data_pointer (gfc_expr
*e
)
604 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
607 /* No subreference if it is a function */
608 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
610 if (e
->symtree
->n
.sym
->attr
.pointer
)
613 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
614 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
621 /* Return true if array variable VAR could be passed to the same function
622 as argument EXPR without interfering with EXPR. INTENT is the intent
625 This is considerably less conservative than other dependencies
626 because many function arguments will already be copied into a
630 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
631 gfc_expr
*expr
, gfc_dep_check elemental
)
635 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
636 gcc_assert (var
->rank
> 0);
638 switch (expr
->expr_type
)
641 /* In case of elemental subroutines, there is no dependency
642 between two same-range array references. */
643 if (gfc_ref_needs_temporary_p (expr
->ref
)
644 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
646 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
648 /* Too many false positive with pointers. */
649 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
651 /* Elemental procedures forbid unspecified intents,
652 and we don't check dependencies for INTENT_IN args. */
653 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
655 /* We are told not to check dependencies.
656 We do it, however, and issue a warning in case we find one.
657 If a dependency is found in the case
658 elemental == ELEM_CHECK_VARIABLE, we will generate
659 a temporary, so we don't need to bother the user. */
660 gfc_warning ("INTENT(%s) actual argument at %L might "
661 "interfere with actual argument at %L.",
662 intent
== INTENT_OUT
? "OUT" : "INOUT",
663 &var
->where
, &expr
->where
);
673 return gfc_check_dependency (var
, expr
, 1);
676 if (intent
!= INTENT_IN
)
678 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
680 return gfc_check_argument_var_dependency (var
, intent
, arg
,
684 if (elemental
!= NOT_ELEMENTAL
)
686 if ((expr
->value
.function
.esym
687 && expr
->value
.function
.esym
->attr
.elemental
)
688 || (expr
->value
.function
.isym
689 && expr
->value
.function
.isym
->elemental
))
690 return gfc_check_fncall_dependency (var
, intent
, NULL
,
691 expr
->value
.function
.actual
,
692 ELEM_CHECK_VARIABLE
);
697 /* In case of non-elemental procedures, there is no need to catch
698 dependencies, as we will make a temporary anyway. */
701 /* If the actual arg EXPR is an expression, we need to catch
702 a dependency between variables in EXPR and VAR,
703 an intent((IN)OUT) variable. */
704 if (expr
->value
.op
.op1
705 && gfc_check_argument_var_dependency (var
, intent
,
707 ELEM_CHECK_VARIABLE
))
709 else if (expr
->value
.op
.op2
710 && gfc_check_argument_var_dependency (var
, intent
,
712 ELEM_CHECK_VARIABLE
))
723 /* Like gfc_check_argument_var_dependency, but extended to any
724 array expression OTHER, not just variables. */
727 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
728 gfc_expr
*expr
, gfc_dep_check elemental
)
730 switch (other
->expr_type
)
733 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
736 other
= gfc_get_noncopying_intrinsic_argument (other
);
738 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
749 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
750 FNSYM is the function being called, or NULL if not known. */
753 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
754 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
755 gfc_dep_check elemental
)
757 gfc_formal_arglist
*formal
;
760 formal
= fnsym
? fnsym
->formal
: NULL
;
761 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
765 /* Skip args which are not present. */
769 /* Skip other itself. */
773 /* Skip intent(in) arguments if OTHER itself is intent(in). */
774 if (formal
&& intent
== INTENT_IN
775 && formal
->sym
->attr
.intent
== INTENT_IN
)
778 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
786 /* Return 1 if e1 and e2 are equivalenced arrays, either
787 directly or indirectly; i.e., equivalence (a,b) for a and b
788 or equivalence (a,c),(b,c). This function uses the equiv_
789 lists, generated in trans-common(add_equivalences), that are
790 guaranteed to pick up indirect equivalences. We explicitly
791 check for overlap using the offset and length of the equivalence.
792 This function is symmetric.
793 TODO: This function only checks whether the full top-level
794 symbols overlap. An improved implementation could inspect
795 e1->ref and e2->ref to determine whether the actually accessed
796 portions of these variables/arrays potentially overlap. */
799 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
802 gfc_equiv_info
*s
, *fl1
, *fl2
;
804 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
805 && e2
->expr_type
== EXPR_VARIABLE
);
807 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
808 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
811 if (e1
->symtree
->n
.sym
->ns
812 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
813 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
815 l
= gfc_current_ns
->equiv_lists
;
817 /* Go through the equiv_lists and return 1 if the variables
818 e1 and e2 are members of the same group and satisfy the
819 requirement on their relative offsets. */
820 for (; l
; l
= l
->next
)
824 for (s
= l
->equiv
; s
; s
= s
->next
)
826 if (s
->sym
== e1
->symtree
->n
.sym
)
832 if (s
->sym
== e2
->symtree
->n
.sym
)
842 /* Can these lengths be zero? */
843 if (fl1
->length
<= 0 || fl2
->length
<= 0)
845 /* These can't overlap if [f11,fl1+length] is before
846 [fl2,fl2+length], or [fl2,fl2+length] is before
847 [fl1,fl1+length], otherwise they do overlap. */
848 if (fl1
->offset
+ fl1
->length
> fl2
->offset
849 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
857 /* Return true if there is no possibility of aliasing because of a type
858 mismatch between all the possible pointer references and the
859 potential target. Note that this function is asymmetric in the
860 arguments and so must be called twice with the arguments exchanged. */
863 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
869 bool seen_component_ref
;
871 if (expr1
->expr_type
!= EXPR_VARIABLE
872 || expr1
->expr_type
!= EXPR_VARIABLE
)
875 sym1
= expr1
->symtree
->n
.sym
;
876 sym2
= expr2
->symtree
->n
.sym
;
878 /* Keep it simple for now. */
879 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
882 if (sym1
->attr
.pointer
)
884 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
888 /* This is a conservative check on the components of the derived type
889 if no component references have been seen. Since we will not dig
890 into the components of derived type components, we play it safe by
891 returning false. First we check the reference chain and then, if
892 no component references have been seen, the components. */
893 seen_component_ref
= false;
894 if (sym1
->ts
.type
== BT_DERIVED
)
896 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
898 if (ref1
->type
!= REF_COMPONENT
)
901 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
904 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
905 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
908 seen_component_ref
= true;
912 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
914 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
916 if (cm1
->ts
.type
== BT_DERIVED
)
919 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
920 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
929 /* Return true if the statement body redefines the condition. Returns
930 true if expr2 depends on expr1. expr1 should be a single term
931 suitable for the lhs of an assignment. The IDENTICAL flag indicates
932 whether array references to the same symbol with identical range
933 references count as a dependency or not. Used for forall and where
934 statements. Also used with functions returning arrays without a
938 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
940 gfc_actual_arglist
*actual
;
944 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
946 switch (expr2
->expr_type
)
949 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
952 if (expr2
->value
.op
.op2
)
953 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
957 /* The interesting cases are when the symbols don't match. */
958 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
960 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
961 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
963 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
964 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
967 /* Symbols can only alias if they have the same type. */
968 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
969 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
971 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
975 /* If either variable is a pointer, assume the worst. */
976 /* TODO: -fassume-no-pointer-aliasing */
977 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
979 if (check_data_pointer_types (expr1
, expr2
)
980 && check_data_pointer_types (expr2
, expr1
))
987 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
988 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
989 if (sym1
->attr
.target
&& sym2
->attr
.target
990 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
991 && (!sym1
->attr
.dimension
992 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
993 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
994 && (!sym2
->attr
.dimension
995 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
999 /* Otherwise distinct symbols have no dependencies. */
1006 /* Identical and disjoint ranges return 0,
1007 overlapping ranges return 1. */
1008 if (expr1
->ref
&& expr2
->ref
)
1009 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
);
1014 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
1017 /* Remember possible differences between elemental and
1018 transformational functions. All functions inside a FORALL
1020 for (actual
= expr2
->value
.function
.actual
;
1021 actual
; actual
= actual
->next
)
1025 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
1036 /* Loop through the array constructor's elements. */
1037 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
1038 c
; c
= gfc_constructor_next (c
))
1040 /* If this is an iterator, assume the worst. */
1043 /* Avoid recursion in the common case. */
1044 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1046 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1057 /* Determines overlapping for two array sections. */
1059 static gfc_dependency
1060 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1076 int stride_comparison
;
1077 int start_comparison
;
1079 /* If they are the same range, return without more ado. */
1080 if (gfc_is_same_range (l_ar
, r_ar
, n
, 0))
1081 return GFC_DEP_EQUAL
;
1083 l_start
= l_ar
->start
[n
];
1084 l_end
= l_ar
->end
[n
];
1085 l_stride
= l_ar
->stride
[n
];
1087 r_start
= r_ar
->start
[n
];
1088 r_end
= r_ar
->end
[n
];
1089 r_stride
= r_ar
->stride
[n
];
1091 /* If l_start is NULL take it from array specifier. */
1092 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1093 l_start
= l_ar
->as
->lower
[n
];
1094 /* If l_end is NULL take it from array specifier. */
1095 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1096 l_end
= l_ar
->as
->upper
[n
];
1098 /* If r_start is NULL take it from array specifier. */
1099 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1100 r_start
= r_ar
->as
->lower
[n
];
1101 /* If r_end is NULL take it from array specifier. */
1102 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1103 r_end
= r_ar
->as
->upper
[n
];
1105 /* Determine whether the l_stride is positive or negative. */
1108 else if (l_stride
->expr_type
== EXPR_CONSTANT
1109 && l_stride
->ts
.type
== BT_INTEGER
)
1110 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1111 else if (l_start
&& l_end
)
1112 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1116 /* Determine whether the r_stride is positive or negative. */
1119 else if (r_stride
->expr_type
== EXPR_CONSTANT
1120 && r_stride
->ts
.type
== BT_INTEGER
)
1121 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1122 else if (r_start
&& r_end
)
1123 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1127 /* The strides should never be zero. */
1128 if (l_dir
== 0 || r_dir
== 0)
1129 return GFC_DEP_OVERLAP
;
1131 /* Determine the relationship between the strides. Set stride_comparison to
1132 -2 if the dependency cannot be determined
1133 -1 if l_stride < r_stride
1134 0 if l_stride == r_stride
1135 1 if l_stride > r_stride
1136 as determined by gfc_dep_compare_expr. */
1138 one_expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1140 stride_comparison
= gfc_dep_compare_expr (l_stride
? l_stride
: one_expr
,
1141 r_stride
? r_stride
: one_expr
);
1143 if (l_start
&& r_start
)
1144 start_comparison
= gfc_dep_compare_expr (l_start
, r_start
);
1146 start_comparison
= -2;
1148 gfc_free (one_expr
);
1150 /* Determine LHS upper and lower bounds. */
1156 else if (l_dir
== -1)
1167 /* Determine RHS upper and lower bounds. */
1173 else if (r_dir
== -1)
1184 /* Check whether the ranges are disjoint. */
1185 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1186 return GFC_DEP_NODEP
;
1187 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1188 return GFC_DEP_NODEP
;
1190 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1191 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1193 if (l_dir
== 1 && r_dir
== -1)
1194 return GFC_DEP_EQUAL
;
1195 if (l_dir
== -1 && r_dir
== 1)
1196 return GFC_DEP_EQUAL
;
1199 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1200 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1202 if (l_dir
== 1 && r_dir
== -1)
1203 return GFC_DEP_EQUAL
;
1204 if (l_dir
== -1 && r_dir
== 1)
1205 return GFC_DEP_EQUAL
;
1208 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1209 There is no dependency if the remainder of
1210 (l_start - r_start) / gcd(l_stride, r_stride) is
1213 - Handle cases where x is an expression.
1214 - Cases like a(1:4:2) = a(2:3) are still not handled.
1217 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1218 && (a)->ts.type == BT_INTEGER)
1220 if (IS_CONSTANT_INTEGER(l_start
) && IS_CONSTANT_INTEGER(r_start
)
1221 && IS_CONSTANT_INTEGER(l_stride
) && IS_CONSTANT_INTEGER(r_stride
))
1229 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1230 mpz_sub (tmp
, l_start
->value
.integer
, r_start
->value
.integer
);
1232 mpz_fdiv_r (tmp
, tmp
, gcd
);
1233 result
= mpz_cmp_si (tmp
, 0L);
1239 return GFC_DEP_NODEP
;
1242 #undef IS_CONSTANT_INTEGER
1244 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1246 if (l_dir
== 1 && r_dir
== 1 &&
1247 (start_comparison
== 0 || start_comparison
== -1)
1248 && (stride_comparison
== 0 || stride_comparison
== -1))
1249 return GFC_DEP_FORWARD
;
1251 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1252 x:y:-1 vs. x:y:-2. */
1253 if (l_dir
== -1 && r_dir
== -1 &&
1254 (start_comparison
== 0 || start_comparison
== 1)
1255 && (stride_comparison
== 0 || stride_comparison
== 1))
1256 return GFC_DEP_FORWARD
;
1258 if (stride_comparison
== 0 || stride_comparison
== -1)
1260 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1263 /* Check for a(low:y:s) vs. a(z:x:s) or
1264 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1265 of low, which is always at least a forward dependence. */
1268 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1269 return GFC_DEP_FORWARD
;
1273 if (stride_comparison
== 0 || stride_comparison
== 1)
1275 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1278 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1279 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1280 of high, which is always at least a forward dependence. */
1283 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1284 return GFC_DEP_FORWARD
;
1289 if (stride_comparison
== 0)
1291 /* From here, check for backwards dependencies. */
1292 /* x+1:y vs. x:z. */
1293 if (l_dir
== 1 && r_dir
== 1 && start_comparison
== 1)
1294 return GFC_DEP_BACKWARD
;
1296 /* x-1:y:-1 vs. x:z:-1. */
1297 if (l_dir
== -1 && r_dir
== -1 && start_comparison
== -1)
1298 return GFC_DEP_BACKWARD
;
1301 return GFC_DEP_OVERLAP
;
1305 /* Determines overlapping for a single element and a section. */
1307 static gfc_dependency
1308 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1317 elem
= lref
->u
.ar
.start
[n
];
1319 return GFC_DEP_OVERLAP
;
1322 start
= ref
->start
[n
] ;
1324 stride
= ref
->stride
[n
];
1326 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1327 start
= ref
->as
->lower
[n
];
1328 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1329 end
= ref
->as
->upper
[n
];
1331 /* Determine whether the stride is positive or negative. */
1334 else if (stride
->expr_type
== EXPR_CONSTANT
1335 && stride
->ts
.type
== BT_INTEGER
)
1336 s
= mpz_sgn (stride
->value
.integer
);
1340 /* Stride should never be zero. */
1342 return GFC_DEP_OVERLAP
;
1344 /* Positive strides. */
1347 /* Check for elem < lower. */
1348 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1349 return GFC_DEP_NODEP
;
1350 /* Check for elem > upper. */
1351 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1352 return GFC_DEP_NODEP
;
1356 s
= gfc_dep_compare_expr (start
, end
);
1357 /* Check for an empty range. */
1359 return GFC_DEP_NODEP
;
1360 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1361 return GFC_DEP_EQUAL
;
1364 /* Negative strides. */
1367 /* Check for elem > upper. */
1368 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1369 return GFC_DEP_NODEP
;
1370 /* Check for elem < lower. */
1371 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1372 return GFC_DEP_NODEP
;
1376 s
= gfc_dep_compare_expr (start
, end
);
1377 /* Check for an empty range. */
1379 return GFC_DEP_NODEP
;
1380 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1381 return GFC_DEP_EQUAL
;
1384 /* Unknown strides. */
1388 return GFC_DEP_OVERLAP
;
1389 s
= gfc_dep_compare_expr (start
, end
);
1391 return GFC_DEP_OVERLAP
;
1392 /* Assume positive stride. */
1395 /* Check for elem < lower. */
1396 if (gfc_dep_compare_expr (elem
, start
) == -1)
1397 return GFC_DEP_NODEP
;
1398 /* Check for elem > upper. */
1399 if (gfc_dep_compare_expr (elem
, end
) == 1)
1400 return GFC_DEP_NODEP
;
1402 /* Assume negative stride. */
1405 /* Check for elem > upper. */
1406 if (gfc_dep_compare_expr (elem
, start
) == 1)
1407 return GFC_DEP_NODEP
;
1408 /* Check for elem < lower. */
1409 if (gfc_dep_compare_expr (elem
, end
) == -1)
1410 return GFC_DEP_NODEP
;
1415 s
= gfc_dep_compare_expr (elem
, start
);
1417 return GFC_DEP_EQUAL
;
1418 if (s
== 1 || s
== -1)
1419 return GFC_DEP_NODEP
;
1423 return GFC_DEP_OVERLAP
;
1427 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1428 forall_index attribute. Return true if any variable may be
1429 being used as a FORALL index. Its safe to pessimistically
1430 return true, and assume a dependency. */
1433 contains_forall_index_p (gfc_expr
*expr
)
1435 gfc_actual_arglist
*arg
;
1443 switch (expr
->expr_type
)
1446 if (expr
->symtree
->n
.sym
->forall_index
)
1451 if (contains_forall_index_p (expr
->value
.op
.op1
)
1452 || contains_forall_index_p (expr
->value
.op
.op2
))
1457 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1458 if (contains_forall_index_p (arg
->expr
))
1464 case EXPR_SUBSTRING
:
1467 case EXPR_STRUCTURE
:
1469 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1470 c
; gfc_constructor_next (c
))
1471 if (contains_forall_index_p (c
->expr
))
1479 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1483 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1484 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1485 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1486 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1494 if (contains_forall_index_p (ref
->u
.ss
.start
)
1495 || contains_forall_index_p (ref
->u
.ss
.end
))
1506 /* Determines overlapping for two single element array references. */
1508 static gfc_dependency
1509 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1519 l_start
= l_ar
.start
[n
] ;
1520 r_start
= r_ar
.start
[n
] ;
1521 i
= gfc_dep_compare_expr (r_start
, l_start
);
1523 return GFC_DEP_EQUAL
;
1525 /* Treat two scalar variables as potentially equal. This allows
1526 us to prove that a(i,:) and a(j,:) have no dependency. See
1527 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1528 Proceedings of the International Conference on Parallel and
1529 Distributed Processing Techniques and Applications (PDPTA2001),
1530 Las Vegas, Nevada, June 2001. */
1531 /* However, we need to be careful when either scalar expression
1532 contains a FORALL index, as these can potentially change value
1533 during the scalarization/traversal of this array reference. */
1534 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1535 return GFC_DEP_OVERLAP
;
1538 return GFC_DEP_NODEP
;
1539 return GFC_DEP_EQUAL
;
1543 /* Determine if an array ref, usually an array section specifies the
1544 entire array. In addition, if the second, pointer argument is
1545 provided, the function will return true if the reference is
1546 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1549 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1553 bool lbound_OK
= true;
1554 bool ubound_OK
= true;
1557 *contiguous
= false;
1559 if (ref
->type
!= REF_ARRAY
)
1562 if (ref
->u
.ar
.type
== AR_FULL
)
1569 if (ref
->u
.ar
.type
!= AR_SECTION
)
1574 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1576 /* If we have a single element in the reference, for the reference
1577 to be full, we need to ascertain that the array has a single
1578 element in this dimension and that we actually reference the
1580 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1582 /* This is unconditionally a contiguous reference if all the
1583 remaining dimensions are elements. */
1587 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1588 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1589 *contiguous
= false;
1593 || !ref
->u
.ar
.as
->lower
[i
]
1594 || !ref
->u
.ar
.as
->upper
[i
]
1595 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1596 ref
->u
.ar
.as
->upper
[i
])
1597 || !ref
->u
.ar
.start
[i
]
1598 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1599 ref
->u
.ar
.as
->lower
[i
]))
1605 /* Check the lower bound. */
1606 if (ref
->u
.ar
.start
[i
]
1608 || !ref
->u
.ar
.as
->lower
[i
]
1609 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1610 ref
->u
.ar
.as
->lower
[i
])))
1612 /* Check the upper bound. */
1613 if (ref
->u
.ar
.end
[i
]
1615 || !ref
->u
.ar
.as
->upper
[i
]
1616 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1617 ref
->u
.ar
.as
->upper
[i
])))
1619 /* Check the stride. */
1620 if (ref
->u
.ar
.stride
[i
]
1621 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1624 /* This is unconditionally a contiguous reference as long as all
1625 the subsequent dimensions are elements. */
1629 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1630 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1631 *contiguous
= false;
1634 if (!lbound_OK
|| !ubound_OK
)
1641 /* Determine if a full array is the same as an array section with one
1642 variable limit. For this to be so, the strides must both be unity
1643 and one of either start == lower or end == upper must be true. */
1646 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1649 bool upper_or_lower
;
1651 if (full_ref
->type
!= REF_ARRAY
)
1653 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1655 if (ref
->type
!= REF_ARRAY
)
1657 if (ref
->u
.ar
.type
!= AR_SECTION
)
1660 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1662 /* If we have a single element in the reference, we need to check
1663 that the array has a single element and that we actually reference
1664 the correct element. */
1665 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1667 if (!full_ref
->u
.ar
.as
1668 || !full_ref
->u
.ar
.as
->lower
[i
]
1669 || !full_ref
->u
.ar
.as
->upper
[i
]
1670 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1671 full_ref
->u
.ar
.as
->upper
[i
])
1672 || !ref
->u
.ar
.start
[i
]
1673 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1674 full_ref
->u
.ar
.as
->lower
[i
]))
1678 /* Check the strides. */
1679 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1681 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1684 upper_or_lower
= false;
1685 /* Check the lower bound. */
1686 if (ref
->u
.ar
.start
[i
]
1688 && full_ref
->u
.ar
.as
->lower
[i
]
1689 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1690 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
1691 upper_or_lower
= true;
1692 /* Check the upper bound. */
1693 if (ref
->u
.ar
.end
[i
]
1695 && full_ref
->u
.ar
.as
->upper
[i
]
1696 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1697 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
1698 upper_or_lower
= true;
1699 if (!upper_or_lower
)
1706 /* Finds if two array references are overlapping or not.
1708 2 : array references are overlapping but reversal of one or
1709 more dimensions will clear the dependency.
1710 1 : array references are overlapping.
1711 0 : array references are identical or not overlapping. */
1714 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
)
1717 gfc_dependency fin_dep
;
1718 gfc_dependency this_dep
;
1720 this_dep
= GFC_DEP_ERROR
;
1721 fin_dep
= GFC_DEP_ERROR
;
1722 /* Dependencies due to pointers should already have been identified.
1723 We only need to check for overlapping array references. */
1725 while (lref
&& rref
)
1727 /* We're resolving from the same base symbol, so both refs should be
1728 the same type. We traverse the reference chain until we find ranges
1729 that are not equal. */
1730 gcc_assert (lref
->type
== rref
->type
);
1734 /* The two ranges can't overlap if they are from different
1736 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1741 /* Substring overlaps are handled by the string assignment code
1742 if there is not an underlying dependency. */
1743 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1747 if (ref_same_as_full_array (lref
, rref
))
1750 if (ref_same_as_full_array (rref
, lref
))
1753 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1755 if (lref
->u
.ar
.type
== AR_FULL
)
1756 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
1758 else if (rref
->u
.ar
.type
== AR_FULL
)
1759 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
1766 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1768 /* Assume dependency when either of array reference is vector
1770 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1771 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1774 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1775 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1776 this_dep
= check_section_vs_section (&lref
->u
.ar
, &rref
->u
.ar
, n
);
1777 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1778 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1779 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1780 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1781 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1782 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1785 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1786 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1787 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1790 /* If any dimension doesn't overlap, we have no dependency. */
1791 if (this_dep
== GFC_DEP_NODEP
)
1794 /* Now deal with the loop reversal logic: This only works on
1795 ranges and is activated by setting
1796 reverse[n] == GFC_CAN_REVERSE
1797 The ability to reverse or not is set by previous conditions
1798 in this dimension. If reversal is not activated, the
1799 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
1800 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1801 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1803 /* Set reverse if backward dependence and not inhibited. */
1804 if (reverse
&& reverse
[n
] != GFC_CANNOT_REVERSE
)
1805 reverse
[n
] = (this_dep
== GFC_DEP_BACKWARD
) ?
1806 GFC_REVERSE_SET
: reverse
[n
];
1808 /* Inhibit loop reversal if dependence not compatible. */
1809 if (reverse
&& reverse
[n
] != GFC_REVERSE_NOT_SET
1810 && this_dep
!= GFC_DEP_EQUAL
1811 && this_dep
!= GFC_DEP_BACKWARD
1812 && this_dep
!= GFC_DEP_NODEP
)
1814 reverse
[n
] = GFC_CANNOT_REVERSE
;
1815 if (this_dep
!= GFC_DEP_FORWARD
)
1816 this_dep
= GFC_DEP_OVERLAP
;
1819 /* If no intention of reversing or reversing is explicitly
1820 inhibited, convert backward dependence to overlap. */
1821 if (this_dep
== GFC_DEP_BACKWARD
1822 && (reverse
== NULL
|| reverse
[n
] == GFC_CANNOT_REVERSE
))
1823 this_dep
= GFC_DEP_OVERLAP
;
1826 /* Overlap codes are in order of priority. We only need to
1827 know the worst one.*/
1828 if (this_dep
> fin_dep
)
1832 /* If this is an equal element, we have to keep going until we find
1833 the "real" array reference. */
1834 if (lref
->u
.ar
.type
== AR_ELEMENT
1835 && rref
->u
.ar
.type
== AR_ELEMENT
1836 && fin_dep
== GFC_DEP_EQUAL
)
1839 /* Exactly matching and forward overlapping ranges don't cause a
1841 if (fin_dep
< GFC_DEP_BACKWARD
)
1844 /* Keep checking. We only have a dependency if
1845 subsequent references also overlap. */
1855 /* If we haven't seen any array refs then something went wrong. */
1856 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1858 /* Assume the worst if we nest to different depths. */
1862 return fin_dep
== GFC_DEP_OVERLAP
;