]>
git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/dependency.c
2 Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010, 2011,
3 2012 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 "coretypes.h"
31 #include "dependency.h"
32 #include "constructor.h"
35 /* static declarations */
37 enum range
{LHS
, RHS
, MID
};
39 /* Dependency types. These must be in reverse order of priority. */
43 GFC_DEP_EQUAL
, /* Identical Ranges. */
44 GFC_DEP_FORWARD
, /* e.g., a(1:3) = a(2:4). */
45 GFC_DEP_BACKWARD
, /* e.g. a(2:4) = a(1:3). */
46 GFC_DEP_OVERLAP
, /* May overlap in some other way. */
47 GFC_DEP_NODEP
/* Distinct ranges. */
52 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
54 /* Forward declarations */
56 static gfc_dependency
check_section_vs_section (gfc_array_ref
*,
57 gfc_array_ref
*, int);
59 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
60 def if the value could not be determined. */
63 gfc_expr_is_one (gfc_expr
*expr
, int def
)
65 gcc_assert (expr
!= NULL
);
67 if (expr
->expr_type
!= EXPR_CONSTANT
)
70 if (expr
->ts
.type
!= BT_INTEGER
)
73 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
76 /* Check if two array references are known to be identical. Calls
77 gfc_dep_compare_expr if necessary for comparing array indices. */
80 identical_array_ref (gfc_array_ref
*a1
, gfc_array_ref
*a2
)
84 if (a1
->type
== AR_FULL
&& a2
->type
== AR_FULL
)
87 if (a1
->type
== AR_SECTION
&& a2
->type
== AR_SECTION
)
89 gcc_assert (a1
->dimen
== a2
->dimen
);
91 for ( i
= 0; i
< a1
->dimen
; i
++)
93 /* TODO: Currently, we punt on an integer array as an index. */
94 if (a1
->dimen_type
[i
] != DIMEN_RANGE
95 || a2
->dimen_type
[i
] != DIMEN_RANGE
)
98 if (check_section_vs_section (a1
, a2
, i
) != GFC_DEP_EQUAL
)
104 if (a1
->type
== AR_ELEMENT
&& a2
->type
== AR_ELEMENT
)
106 gcc_assert (a1
->dimen
== a2
->dimen
);
107 for (i
= 0; i
< a1
->dimen
; i
++)
109 if (gfc_dep_compare_expr (a1
->start
[i
], a2
->start
[i
]) != 0)
119 /* Return true for identical variables, checking for references if
120 necessary. Calls identical_array_ref for checking array sections. */
123 are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
127 if (e1
->symtree
->n
.sym
->attr
.dummy
&& e2
->symtree
->n
.sym
->attr
.dummy
)
129 /* Dummy arguments: Only check for equal names. */
130 if (e1
->symtree
->n
.sym
->name
!= e2
->symtree
->n
.sym
->name
)
135 /* Check for equal symbols. */
136 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
140 /* Volatile variables should never compare equal to themselves. */
142 if (e1
->symtree
->n
.sym
->attr
.volatile_
)
148 while (r1
!= NULL
|| r2
!= NULL
)
151 /* Assume the variables are not equal if one has a reference and the
153 TODO: Handle full references like comparing a(:) to a.
156 if (r1
== NULL
|| r2
== NULL
)
159 if (r1
->type
!= r2
->type
)
166 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
172 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
177 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0)
180 /* If both are NULL, the end length compares equal, because we
181 are looking at the same variable. This can only happen for
182 assumed- or deferred-length character arguments. */
184 if (r1
->u
.ss
.end
== NULL
&& r2
->u
.ss
.end
== NULL
)
187 if (gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
193 gfc_internal_error ("are_identical_variables: Bad type");
201 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
202 impure_ok is false, only return 0 for pure functions. */
205 gfc_dep_compare_functions (gfc_expr
*e1
, gfc_expr
*e2
, bool impure_ok
)
208 gfc_actual_arglist
*args1
;
209 gfc_actual_arglist
*args2
;
211 if (e1
->expr_type
!= EXPR_FUNCTION
|| e2
->expr_type
!= EXPR_FUNCTION
)
214 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
215 && e1
->value
.function
.esym
== e2
->value
.function
.esym
216 && (e1
->value
.function
.esym
->result
->attr
.pure
|| impure_ok
))
217 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
218 && e1
->value
.function
.isym
== e2
->value
.function
.isym
219 && (e1
->value
.function
.isym
->pure
|| impure_ok
)))
221 args1
= e1
->value
.function
.actual
;
222 args2
= e2
->value
.function
.actual
;
224 /* Compare the argument lists for equality. */
225 while (args1
&& args2
)
227 /* Bitwise xor, since C has no non-bitwise xor operator. */
228 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
231 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
232 && gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
238 return (args1
|| args2
) ? -2 : 0;
244 /* Compare two expressions. Return values:
248 * -2 if the relationship could not be determined
249 * -3 if e1 /= e2, but we cannot tell which one is larger.
250 REAL and COMPLEX constants are only compared for equality
251 or inequality; if they are unequal, -2 is returned in all cases. */
254 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
256 gfc_actual_arglist
*args1
;
257 gfc_actual_arglist
*args2
;
264 if (e1
== NULL
&& e2
== NULL
)
267 /* Remove any integer conversion functions to larger types. */
268 if (e1
->expr_type
== EXPR_FUNCTION
&& e1
->value
.function
.isym
269 && e1
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
270 && e1
->ts
.type
== BT_INTEGER
)
272 args1
= e1
->value
.function
.actual
;
273 if (args1
->expr
->ts
.type
== BT_INTEGER
274 && e1
->ts
.kind
> args1
->expr
->ts
.kind
)
278 if (e2
->expr_type
== EXPR_FUNCTION
&& e2
->value
.function
.isym
279 && e2
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
280 && e2
->ts
.type
== BT_INTEGER
)
282 args2
= e2
->value
.function
.actual
;
283 if (args2
->expr
->ts
.type
== BT_INTEGER
284 && e2
->ts
.kind
> args2
->expr
->ts
.kind
)
291 return gfc_dep_compare_expr (n1
, n2
);
293 return gfc_dep_compare_expr (n1
, e2
);
298 return gfc_dep_compare_expr (e1
, n2
);
301 if (e1
->expr_type
== EXPR_OP
302 && (e1
->value
.op
.op
== INTRINSIC_UPLUS
303 || e1
->value
.op
.op
== INTRINSIC_PARENTHESES
))
304 return gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
);
305 if (e2
->expr_type
== EXPR_OP
306 && (e2
->value
.op
.op
== INTRINSIC_UPLUS
307 || e2
->value
.op
.op
== INTRINSIC_PARENTHESES
))
308 return gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
);
310 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
312 /* Compare X+C vs. X, for INTEGER only. */
313 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
314 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
315 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
316 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
318 /* Compare P+Q vs. R+S. */
319 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
323 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
324 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
325 if (l
== 0 && r
== 0)
327 if (l
== 0 && r
> -2)
329 if (l
> -2 && r
== 0)
331 if (l
== 1 && r
== 1)
333 if (l
== -1 && r
== -1)
336 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
337 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
338 if (l
== 0 && r
== 0)
340 if (l
== 0 && r
> -2)
342 if (l
> -2 && r
== 0)
344 if (l
== 1 && r
== 1)
346 if (l
== -1 && r
== -1)
351 /* Compare X vs. X+C, for INTEGER only. */
352 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
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 /* Compare X-C vs. X, for INTEGER only. */
361 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
363 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
364 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
365 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
366 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
368 /* Compare P-Q vs. R-S. */
369 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
373 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
374 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
375 if (l
== 0 && r
== 0)
377 if (l
> -2 && r
== 0)
379 if (l
== 0 && r
> -2)
381 if (l
== 1 && r
== -1)
383 if (l
== -1 && r
== 1)
388 /* Compare A // B vs. C // D. */
390 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_CONCAT
391 && e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_CONCAT
)
395 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
396 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
401 /* Left expressions of // compare equal, but
402 watch out for 'A ' // x vs. 'A' // x. */
403 gfc_expr
*e1_left
= e1
->value
.op
.op1
;
404 gfc_expr
*e2_left
= e2
->value
.op
.op1
;
406 if (e1_left
->expr_type
== EXPR_CONSTANT
407 && e2_left
->expr_type
== EXPR_CONSTANT
408 && e1_left
->value
.character
.length
409 != e2_left
->value
.character
.length
)
415 /* Compare X vs. X-C, for INTEGER only. */
416 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
418 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
419 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
420 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
421 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
424 if (e1
->expr_type
!= e2
->expr_type
)
427 switch (e1
->expr_type
)
430 /* Compare strings for equality. */
431 if (e1
->ts
.type
== BT_CHARACTER
&& e2
->ts
.type
== BT_CHARACTER
)
432 return gfc_compare_string (e1
, e2
);
434 /* Compare REAL and COMPLEX constants. Because of the
435 traps and pitfalls associated with comparing
436 a + 1.0 with a + 0.5, check for equality only. */
437 if (e2
->expr_type
== EXPR_CONSTANT
)
439 if (e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
)
441 if (mpfr_cmp (e1
->value
.real
, e2
->value
.real
) == 0)
446 else if (e1
->ts
.type
== BT_COMPLEX
&& e2
->ts
.type
== BT_COMPLEX
)
448 if (mpc_cmp (e1
->value
.complex, e2
->value
.complex) == 0)
455 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
458 /* For INTEGER, all cases where e2 is not constant should have
459 been filtered out above. */
460 gcc_assert (e2
->expr_type
== EXPR_CONSTANT
);
462 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
470 if (are_identical_variables (e1
, e2
))
476 /* Intrinsic operators are the same if their operands are the same. */
477 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
479 if (e1
->value
.op
.op2
== 0)
481 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
482 return i
== 0 ? 0 : -2;
484 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
485 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
487 else if (e1
->value
.op
.op
== INTRINSIC_TIMES
488 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
) == 0
489 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
) == 0)
490 /* Commutativity of multiplication; addition is handled above. */
496 return gfc_dep_compare_functions (e1
, e2
, false);
505 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
506 results are indeterminate). 'n' is the dimension to compare. */
509 is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
)
515 /* TODO: More sophisticated range comparison. */
516 gcc_assert (ar1
&& ar2
);
518 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
522 /* Check for mismatching strides. A NULL stride means a stride of 1. */
525 i
= gfc_expr_is_one (e1
, -1);
526 if (i
== -1 || i
== 0)
531 i
= gfc_expr_is_one (e2
, -1);
532 if (i
== -1 || i
== 0)
537 i
= gfc_dep_compare_expr (e1
, e2
);
541 /* The strides match. */
543 /* Check the range start. */
548 /* Use the bound of the array if no bound is specified. */
550 e1
= ar1
->as
->lower
[n
];
553 e2
= ar2
->as
->lower
[n
];
555 /* Check we have values for both. */
559 i
= gfc_dep_compare_expr (e1
, e2
);
564 /* Check the range end. */
569 /* Use the bound of the array if no bound is specified. */
571 e1
= ar1
->as
->upper
[n
];
574 e2
= ar2
->as
->upper
[n
];
576 /* Check we have values for both. */
580 i
= gfc_dep_compare_expr (e1
, e2
);
589 /* Some array-returning intrinsics can be implemented by reusing the
590 data from one of the array arguments. For example, TRANSPOSE does
591 not necessarily need to allocate new data: it can be implemented
592 by copying the original array's descriptor and simply swapping the
593 two dimension specifications.
595 If EXPR is a call to such an intrinsic, return the argument
596 whose data can be reused, otherwise return NULL. */
599 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
601 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
604 switch (expr
->value
.function
.isym
->id
)
606 case GFC_ISYM_TRANSPOSE
:
607 return expr
->value
.function
.actual
->expr
;
615 /* Return true if the result of reference REF can only be constructed
616 using a temporary array. */
619 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
625 for (; ref
; ref
= ref
->next
)
629 /* Vector dimensions are generally not monotonic and must be
630 handled using a temporary. */
631 if (ref
->u
.ar
.type
== AR_SECTION
)
632 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
633 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
640 /* Within an array reference, character substrings generally
641 need a temporary. Character array strides are expressed as
642 multiples of the element size (consistent with other array
643 types), not in characters. */
655 gfc_is_data_pointer (gfc_expr
*e
)
659 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
662 /* No subreference if it is a function */
663 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
665 if (e
->symtree
->n
.sym
->attr
.pointer
)
668 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
669 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
676 /* Return true if array variable VAR could be passed to the same function
677 as argument EXPR without interfering with EXPR. INTENT is the intent
680 This is considerably less conservative than other dependencies
681 because many function arguments will already be copied into a
685 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
686 gfc_expr
*expr
, gfc_dep_check elemental
)
690 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
691 gcc_assert (var
->rank
> 0);
693 switch (expr
->expr_type
)
696 /* In case of elemental subroutines, there is no dependency
697 between two same-range array references. */
698 if (gfc_ref_needs_temporary_p (expr
->ref
)
699 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
701 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
703 /* Too many false positive with pointers. */
704 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
706 /* Elemental procedures forbid unspecified intents,
707 and we don't check dependencies for INTENT_IN args. */
708 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
710 /* We are told not to check dependencies.
711 We do it, however, and issue a warning in case we find one.
712 If a dependency is found in the case
713 elemental == ELEM_CHECK_VARIABLE, we will generate
714 a temporary, so we don't need to bother the user. */
715 gfc_warning ("INTENT(%s) actual argument at %L might "
716 "interfere with actual argument at %L.",
717 intent
== INTENT_OUT
? "OUT" : "INOUT",
718 &var
->where
, &expr
->where
);
728 return gfc_check_dependency (var
, expr
, 1);
731 if (intent
!= INTENT_IN
)
733 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
735 return gfc_check_argument_var_dependency (var
, intent
, arg
,
739 if (elemental
!= NOT_ELEMENTAL
)
741 if ((expr
->value
.function
.esym
742 && expr
->value
.function
.esym
->attr
.elemental
)
743 || (expr
->value
.function
.isym
744 && expr
->value
.function
.isym
->elemental
))
745 return gfc_check_fncall_dependency (var
, intent
, NULL
,
746 expr
->value
.function
.actual
,
747 ELEM_CHECK_VARIABLE
);
749 if (gfc_inline_intrinsic_function_p (expr
))
751 /* The TRANSPOSE case should have been caught in the
752 noncopying intrinsic case above. */
753 gcc_assert (expr
->value
.function
.isym
->id
!= GFC_ISYM_TRANSPOSE
);
755 return gfc_check_fncall_dependency (var
, intent
, NULL
,
756 expr
->value
.function
.actual
,
757 ELEM_CHECK_VARIABLE
);
763 /* In case of non-elemental procedures, there is no need to catch
764 dependencies, as we will make a temporary anyway. */
767 /* If the actual arg EXPR is an expression, we need to catch
768 a dependency between variables in EXPR and VAR,
769 an intent((IN)OUT) variable. */
770 if (expr
->value
.op
.op1
771 && gfc_check_argument_var_dependency (var
, intent
,
773 ELEM_CHECK_VARIABLE
))
775 else if (expr
->value
.op
.op2
776 && gfc_check_argument_var_dependency (var
, intent
,
778 ELEM_CHECK_VARIABLE
))
789 /* Like gfc_check_argument_var_dependency, but extended to any
790 array expression OTHER, not just variables. */
793 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
794 gfc_expr
*expr
, gfc_dep_check elemental
)
796 switch (other
->expr_type
)
799 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
802 other
= gfc_get_noncopying_intrinsic_argument (other
);
804 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
815 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
816 FNSYM is the function being called, or NULL if not known. */
819 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
820 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
821 gfc_dep_check elemental
)
823 gfc_formal_arglist
*formal
;
826 formal
= fnsym
? fnsym
->formal
: NULL
;
827 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
831 /* Skip args which are not present. */
835 /* Skip other itself. */
839 /* Skip intent(in) arguments if OTHER itself is intent(in). */
840 if (formal
&& intent
== INTENT_IN
841 && formal
->sym
->attr
.intent
== INTENT_IN
)
844 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
852 /* Return 1 if e1 and e2 are equivalenced arrays, either
853 directly or indirectly; i.e., equivalence (a,b) for a and b
854 or equivalence (a,c),(b,c). This function uses the equiv_
855 lists, generated in trans-common(add_equivalences), that are
856 guaranteed to pick up indirect equivalences. We explicitly
857 check for overlap using the offset and length of the equivalence.
858 This function is symmetric.
859 TODO: This function only checks whether the full top-level
860 symbols overlap. An improved implementation could inspect
861 e1->ref and e2->ref to determine whether the actually accessed
862 portions of these variables/arrays potentially overlap. */
865 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
868 gfc_equiv_info
*s
, *fl1
, *fl2
;
870 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
871 && e2
->expr_type
== EXPR_VARIABLE
);
873 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
874 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
877 if (e1
->symtree
->n
.sym
->ns
878 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
879 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
881 l
= gfc_current_ns
->equiv_lists
;
883 /* Go through the equiv_lists and return 1 if the variables
884 e1 and e2 are members of the same group and satisfy the
885 requirement on their relative offsets. */
886 for (; l
; l
= l
->next
)
890 for (s
= l
->equiv
; s
; s
= s
->next
)
892 if (s
->sym
== e1
->symtree
->n
.sym
)
898 if (s
->sym
== e2
->symtree
->n
.sym
)
908 /* Can these lengths be zero? */
909 if (fl1
->length
<= 0 || fl2
->length
<= 0)
911 /* These can't overlap if [f11,fl1+length] is before
912 [fl2,fl2+length], or [fl2,fl2+length] is before
913 [fl1,fl1+length], otherwise they do overlap. */
914 if (fl1
->offset
+ fl1
->length
> fl2
->offset
915 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
923 /* Return true if there is no possibility of aliasing because of a type
924 mismatch between all the possible pointer references and the
925 potential target. Note that this function is asymmetric in the
926 arguments and so must be called twice with the arguments exchanged. */
929 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
935 bool seen_component_ref
;
937 if (expr1
->expr_type
!= EXPR_VARIABLE
938 || expr1
->expr_type
!= EXPR_VARIABLE
)
941 sym1
= expr1
->symtree
->n
.sym
;
942 sym2
= expr2
->symtree
->n
.sym
;
944 /* Keep it simple for now. */
945 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
948 if (sym1
->attr
.pointer
)
950 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
954 /* This is a conservative check on the components of the derived type
955 if no component references have been seen. Since we will not dig
956 into the components of derived type components, we play it safe by
957 returning false. First we check the reference chain and then, if
958 no component references have been seen, the components. */
959 seen_component_ref
= false;
960 if (sym1
->ts
.type
== BT_DERIVED
)
962 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
964 if (ref1
->type
!= REF_COMPONENT
)
967 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
970 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
971 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
974 seen_component_ref
= true;
978 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
980 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
982 if (cm1
->ts
.type
== BT_DERIVED
)
985 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
986 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
995 /* Return true if the statement body redefines the condition. Returns
996 true if expr2 depends on expr1. expr1 should be a single term
997 suitable for the lhs of an assignment. The IDENTICAL flag indicates
998 whether array references to the same symbol with identical range
999 references count as a dependency or not. Used for forall and where
1000 statements. Also used with functions returning arrays without a
1004 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
1006 gfc_actual_arglist
*actual
;
1010 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1012 switch (expr2
->expr_type
)
1015 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
1018 if (expr2
->value
.op
.op2
)
1019 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
1023 /* The interesting cases are when the symbols don't match. */
1024 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
1026 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
1027 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
1029 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1030 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
1033 /* Symbols can only alias if they have the same type. */
1034 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
1035 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
1037 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
1041 /* If either variable is a pointer, assume the worst. */
1042 /* TODO: -fassume-no-pointer-aliasing */
1043 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
1045 if (check_data_pointer_types (expr1
, expr2
)
1046 && check_data_pointer_types (expr2
, expr1
))
1053 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
1054 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
1055 if (sym1
->attr
.target
&& sym2
->attr
.target
1056 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
1057 && (!sym1
->attr
.dimension
1058 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
1059 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
1060 && (!sym2
->attr
.dimension
1061 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
1065 /* Otherwise distinct symbols have no dependencies. */
1072 /* Identical and disjoint ranges return 0,
1073 overlapping ranges return 1. */
1074 if (expr1
->ref
&& expr2
->ref
)
1075 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
);
1080 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
1083 /* Remember possible differences between elemental and
1084 transformational functions. All functions inside a FORALL
1086 for (actual
= expr2
->value
.function
.actual
;
1087 actual
; actual
= actual
->next
)
1091 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
1102 /* Loop through the array constructor's elements. */
1103 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
1104 c
; c
= gfc_constructor_next (c
))
1106 /* If this is an iterator, assume the worst. */
1109 /* Avoid recursion in the common case. */
1110 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1112 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1123 /* Determines overlapping for two array sections. */
1125 static gfc_dependency
1126 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1142 int stride_comparison
;
1143 int start_comparison
;
1145 /* If they are the same range, return without more ado. */
1146 if (is_same_range (l_ar
, r_ar
, n
))
1147 return GFC_DEP_EQUAL
;
1149 l_start
= l_ar
->start
[n
];
1150 l_end
= l_ar
->end
[n
];
1151 l_stride
= l_ar
->stride
[n
];
1153 r_start
= r_ar
->start
[n
];
1154 r_end
= r_ar
->end
[n
];
1155 r_stride
= r_ar
->stride
[n
];
1157 /* If l_start is NULL take it from array specifier. */
1158 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1159 l_start
= l_ar
->as
->lower
[n
];
1160 /* If l_end is NULL take it from array specifier. */
1161 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1162 l_end
= l_ar
->as
->upper
[n
];
1164 /* If r_start is NULL take it from array specifier. */
1165 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1166 r_start
= r_ar
->as
->lower
[n
];
1167 /* If r_end is NULL take it from array specifier. */
1168 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1169 r_end
= r_ar
->as
->upper
[n
];
1171 /* Determine whether the l_stride is positive or negative. */
1174 else if (l_stride
->expr_type
== EXPR_CONSTANT
1175 && l_stride
->ts
.type
== BT_INTEGER
)
1176 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1177 else if (l_start
&& l_end
)
1178 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1182 /* Determine whether the r_stride is positive or negative. */
1185 else if (r_stride
->expr_type
== EXPR_CONSTANT
1186 && r_stride
->ts
.type
== BT_INTEGER
)
1187 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1188 else if (r_start
&& r_end
)
1189 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1193 /* The strides should never be zero. */
1194 if (l_dir
== 0 || r_dir
== 0)
1195 return GFC_DEP_OVERLAP
;
1197 /* Determine the relationship between the strides. Set stride_comparison to
1198 -2 if the dependency cannot be determined
1199 -1 if l_stride < r_stride
1200 0 if l_stride == r_stride
1201 1 if l_stride > r_stride
1202 as determined by gfc_dep_compare_expr. */
1204 one_expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1206 stride_comparison
= gfc_dep_compare_expr (l_stride
? l_stride
: one_expr
,
1207 r_stride
? r_stride
: one_expr
);
1209 if (l_start
&& r_start
)
1210 start_comparison
= gfc_dep_compare_expr (l_start
, r_start
);
1212 start_comparison
= -2;
1214 gfc_free_expr (one_expr
);
1216 /* Determine LHS upper and lower bounds. */
1222 else if (l_dir
== -1)
1233 /* Determine RHS upper and lower bounds. */
1239 else if (r_dir
== -1)
1250 /* Check whether the ranges are disjoint. */
1251 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1252 return GFC_DEP_NODEP
;
1253 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1254 return GFC_DEP_NODEP
;
1256 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1257 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1259 if (l_dir
== 1 && r_dir
== -1)
1260 return GFC_DEP_EQUAL
;
1261 if (l_dir
== -1 && r_dir
== 1)
1262 return GFC_DEP_EQUAL
;
1265 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1266 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1268 if (l_dir
== 1 && r_dir
== -1)
1269 return GFC_DEP_EQUAL
;
1270 if (l_dir
== -1 && r_dir
== 1)
1271 return GFC_DEP_EQUAL
;
1274 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1275 There is no dependency if the remainder of
1276 (l_start - r_start) / gcd(l_stride, r_stride) is
1279 - Handle cases where x is an expression.
1280 - Cases like a(1:4:2) = a(2:3) are still not handled.
1283 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1284 && (a)->ts.type == BT_INTEGER)
1286 if (IS_CONSTANT_INTEGER(l_start
) && IS_CONSTANT_INTEGER(r_start
)
1287 && IS_CONSTANT_INTEGER(l_stride
) && IS_CONSTANT_INTEGER(r_stride
))
1295 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1296 mpz_sub (tmp
, l_start
->value
.integer
, r_start
->value
.integer
);
1298 mpz_fdiv_r (tmp
, tmp
, gcd
);
1299 result
= mpz_cmp_si (tmp
, 0L);
1305 return GFC_DEP_NODEP
;
1308 #undef IS_CONSTANT_INTEGER
1310 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1312 if (l_dir
== 1 && r_dir
== 1 &&
1313 (start_comparison
== 0 || start_comparison
== -1)
1314 && (stride_comparison
== 0 || stride_comparison
== -1))
1315 return GFC_DEP_FORWARD
;
1317 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1318 x:y:-1 vs. x:y:-2. */
1319 if (l_dir
== -1 && r_dir
== -1 &&
1320 (start_comparison
== 0 || start_comparison
== 1)
1321 && (stride_comparison
== 0 || stride_comparison
== 1))
1322 return GFC_DEP_FORWARD
;
1324 if (stride_comparison
== 0 || stride_comparison
== -1)
1326 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1329 /* Check for a(low:y:s) vs. a(z:x:s) or
1330 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1331 of low, which is always at least a forward dependence. */
1334 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1335 return GFC_DEP_FORWARD
;
1339 if (stride_comparison
== 0 || stride_comparison
== 1)
1341 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1344 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1345 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1346 of high, which is always at least a forward dependence. */
1349 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1350 return GFC_DEP_FORWARD
;
1355 if (stride_comparison
== 0)
1357 /* From here, check for backwards dependencies. */
1358 /* x+1:y vs. x:z. */
1359 if (l_dir
== 1 && r_dir
== 1 && start_comparison
== 1)
1360 return GFC_DEP_BACKWARD
;
1362 /* x-1:y:-1 vs. x:z:-1. */
1363 if (l_dir
== -1 && r_dir
== -1 && start_comparison
== -1)
1364 return GFC_DEP_BACKWARD
;
1367 return GFC_DEP_OVERLAP
;
1371 /* Determines overlapping for a single element and a section. */
1373 static gfc_dependency
1374 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1383 elem
= lref
->u
.ar
.start
[n
];
1385 return GFC_DEP_OVERLAP
;
1388 start
= ref
->start
[n
] ;
1390 stride
= ref
->stride
[n
];
1392 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1393 start
= ref
->as
->lower
[n
];
1394 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1395 end
= ref
->as
->upper
[n
];
1397 /* Determine whether the stride is positive or negative. */
1400 else if (stride
->expr_type
== EXPR_CONSTANT
1401 && stride
->ts
.type
== BT_INTEGER
)
1402 s
= mpz_sgn (stride
->value
.integer
);
1406 /* Stride should never be zero. */
1408 return GFC_DEP_OVERLAP
;
1410 /* Positive strides. */
1413 /* Check for elem < lower. */
1414 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1415 return GFC_DEP_NODEP
;
1416 /* Check for elem > upper. */
1417 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1418 return GFC_DEP_NODEP
;
1422 s
= gfc_dep_compare_expr (start
, end
);
1423 /* Check for an empty range. */
1425 return GFC_DEP_NODEP
;
1426 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1427 return GFC_DEP_EQUAL
;
1430 /* Negative strides. */
1433 /* Check for elem > upper. */
1434 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1435 return GFC_DEP_NODEP
;
1436 /* Check for elem < lower. */
1437 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1438 return GFC_DEP_NODEP
;
1442 s
= gfc_dep_compare_expr (start
, end
);
1443 /* Check for an empty range. */
1445 return GFC_DEP_NODEP
;
1446 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1447 return GFC_DEP_EQUAL
;
1450 /* Unknown strides. */
1454 return GFC_DEP_OVERLAP
;
1455 s
= gfc_dep_compare_expr (start
, end
);
1457 return GFC_DEP_OVERLAP
;
1458 /* Assume positive stride. */
1461 /* Check for elem < lower. */
1462 if (gfc_dep_compare_expr (elem
, start
) == -1)
1463 return GFC_DEP_NODEP
;
1464 /* Check for elem > upper. */
1465 if (gfc_dep_compare_expr (elem
, end
) == 1)
1466 return GFC_DEP_NODEP
;
1468 /* Assume negative stride. */
1471 /* Check for elem > upper. */
1472 if (gfc_dep_compare_expr (elem
, start
) == 1)
1473 return GFC_DEP_NODEP
;
1474 /* Check for elem < lower. */
1475 if (gfc_dep_compare_expr (elem
, end
) == -1)
1476 return GFC_DEP_NODEP
;
1481 s
= gfc_dep_compare_expr (elem
, start
);
1483 return GFC_DEP_EQUAL
;
1484 if (s
== 1 || s
== -1)
1485 return GFC_DEP_NODEP
;
1489 return GFC_DEP_OVERLAP
;
1493 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1494 forall_index attribute. Return true if any variable may be
1495 being used as a FORALL index. Its safe to pessimistically
1496 return true, and assume a dependency. */
1499 contains_forall_index_p (gfc_expr
*expr
)
1501 gfc_actual_arglist
*arg
;
1509 switch (expr
->expr_type
)
1512 if (expr
->symtree
->n
.sym
->forall_index
)
1517 if (contains_forall_index_p (expr
->value
.op
.op1
)
1518 || contains_forall_index_p (expr
->value
.op
.op2
))
1523 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1524 if (contains_forall_index_p (arg
->expr
))
1530 case EXPR_SUBSTRING
:
1533 case EXPR_STRUCTURE
:
1535 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1536 c
; gfc_constructor_next (c
))
1537 if (contains_forall_index_p (c
->expr
))
1545 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1549 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1550 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1551 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1552 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1560 if (contains_forall_index_p (ref
->u
.ss
.start
)
1561 || contains_forall_index_p (ref
->u
.ss
.end
))
1572 /* Determines overlapping for two single element array references. */
1574 static gfc_dependency
1575 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1585 l_start
= l_ar
.start
[n
] ;
1586 r_start
= r_ar
.start
[n
] ;
1587 i
= gfc_dep_compare_expr (r_start
, l_start
);
1589 return GFC_DEP_EQUAL
;
1591 /* Treat two scalar variables as potentially equal. This allows
1592 us to prove that a(i,:) and a(j,:) have no dependency. See
1593 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1594 Proceedings of the International Conference on Parallel and
1595 Distributed Processing Techniques and Applications (PDPTA2001),
1596 Las Vegas, Nevada, June 2001. */
1597 /* However, we need to be careful when either scalar expression
1598 contains a FORALL index, as these can potentially change value
1599 during the scalarization/traversal of this array reference. */
1600 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1601 return GFC_DEP_OVERLAP
;
1604 return GFC_DEP_NODEP
;
1605 return GFC_DEP_EQUAL
;
1609 /* Determine if an array ref, usually an array section specifies the
1610 entire array. In addition, if the second, pointer argument is
1611 provided, the function will return true if the reference is
1612 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1615 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1619 bool lbound_OK
= true;
1620 bool ubound_OK
= true;
1623 *contiguous
= false;
1625 if (ref
->type
!= REF_ARRAY
)
1628 if (ref
->u
.ar
.type
== AR_FULL
)
1635 if (ref
->u
.ar
.type
!= AR_SECTION
)
1640 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1642 /* If we have a single element in the reference, for the reference
1643 to be full, we need to ascertain that the array has a single
1644 element in this dimension and that we actually reference the
1646 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1648 /* This is unconditionally a contiguous reference if all the
1649 remaining dimensions are elements. */
1653 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1654 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1655 *contiguous
= false;
1659 || !ref
->u
.ar
.as
->lower
[i
]
1660 || !ref
->u
.ar
.as
->upper
[i
]
1661 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1662 ref
->u
.ar
.as
->upper
[i
])
1663 || !ref
->u
.ar
.start
[i
]
1664 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1665 ref
->u
.ar
.as
->lower
[i
]))
1671 /* Check the lower bound. */
1672 if (ref
->u
.ar
.start
[i
]
1674 || !ref
->u
.ar
.as
->lower
[i
]
1675 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1676 ref
->u
.ar
.as
->lower
[i
])))
1678 /* Check the upper bound. */
1679 if (ref
->u
.ar
.end
[i
]
1681 || !ref
->u
.ar
.as
->upper
[i
]
1682 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1683 ref
->u
.ar
.as
->upper
[i
])))
1685 /* Check the stride. */
1686 if (ref
->u
.ar
.stride
[i
]
1687 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1690 /* This is unconditionally a contiguous reference as long as all
1691 the subsequent dimensions are elements. */
1695 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1696 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1697 *contiguous
= false;
1700 if (!lbound_OK
|| !ubound_OK
)
1707 /* Determine if a full array is the same as an array section with one
1708 variable limit. For this to be so, the strides must both be unity
1709 and one of either start == lower or end == upper must be true. */
1712 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1715 bool upper_or_lower
;
1717 if (full_ref
->type
!= REF_ARRAY
)
1719 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1721 if (ref
->type
!= REF_ARRAY
)
1723 if (ref
->u
.ar
.type
!= AR_SECTION
)
1726 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1728 /* If we have a single element in the reference, we need to check
1729 that the array has a single element and that we actually reference
1730 the correct element. */
1731 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1733 if (!full_ref
->u
.ar
.as
1734 || !full_ref
->u
.ar
.as
->lower
[i
]
1735 || !full_ref
->u
.ar
.as
->upper
[i
]
1736 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1737 full_ref
->u
.ar
.as
->upper
[i
])
1738 || !ref
->u
.ar
.start
[i
]
1739 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1740 full_ref
->u
.ar
.as
->lower
[i
]))
1744 /* Check the strides. */
1745 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1747 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1750 upper_or_lower
= false;
1751 /* Check the lower bound. */
1752 if (ref
->u
.ar
.start
[i
]
1754 && full_ref
->u
.ar
.as
->lower
[i
]
1755 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1756 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
1757 upper_or_lower
= true;
1758 /* Check the upper bound. */
1759 if (ref
->u
.ar
.end
[i
]
1761 && full_ref
->u
.ar
.as
->upper
[i
]
1762 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1763 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
1764 upper_or_lower
= true;
1765 if (!upper_or_lower
)
1772 /* Finds if two array references are overlapping or not.
1774 2 : array references are overlapping but reversal of one or
1775 more dimensions will clear the dependency.
1776 1 : array references are overlapping.
1777 0 : array references are identical or not overlapping. */
1780 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
)
1783 gfc_dependency fin_dep
;
1784 gfc_dependency this_dep
;
1786 this_dep
= GFC_DEP_ERROR
;
1787 fin_dep
= GFC_DEP_ERROR
;
1788 /* Dependencies due to pointers should already have been identified.
1789 We only need to check for overlapping array references. */
1791 while (lref
&& rref
)
1793 /* We're resolving from the same base symbol, so both refs should be
1794 the same type. We traverse the reference chain until we find ranges
1795 that are not equal. */
1796 gcc_assert (lref
->type
== rref
->type
);
1800 /* The two ranges can't overlap if they are from different
1802 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
1807 /* Substring overlaps are handled by the string assignment code
1808 if there is not an underlying dependency. */
1809 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
1813 if (ref_same_as_full_array (lref
, rref
))
1816 if (ref_same_as_full_array (rref
, lref
))
1819 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
1821 if (lref
->u
.ar
.type
== AR_FULL
)
1822 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
1824 else if (rref
->u
.ar
.type
== AR_FULL
)
1825 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
1832 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
1834 /* Assume dependency when either of array reference is vector
1836 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
1837 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
1840 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1841 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1842 this_dep
= check_section_vs_section (&lref
->u
.ar
, &rref
->u
.ar
, n
);
1843 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1844 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1845 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
1846 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1847 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1848 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
1851 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
1852 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
1853 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
1856 /* If any dimension doesn't overlap, we have no dependency. */
1857 if (this_dep
== GFC_DEP_NODEP
)
1860 /* Now deal with the loop reversal logic: This only works on
1861 ranges and is activated by setting
1862 reverse[n] == GFC_ENABLE_REVERSE
1863 The ability to reverse or not is set by previous conditions
1864 in this dimension. If reversal is not activated, the
1865 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
1866 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
1867 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
1869 /* Set reverse if backward dependence and not inhibited. */
1870 if (reverse
&& reverse
[n
] == GFC_ENABLE_REVERSE
)
1871 reverse
[n
] = (this_dep
== GFC_DEP_BACKWARD
) ?
1872 GFC_REVERSE_SET
: reverse
[n
];
1874 /* Set forward if forward dependence and not inhibited. */
1875 if (reverse
&& reverse
[n
] == GFC_ENABLE_REVERSE
)
1876 reverse
[n
] = (this_dep
== GFC_DEP_FORWARD
) ?
1877 GFC_FORWARD_SET
: reverse
[n
];
1879 /* Flag up overlap if dependence not compatible with
1880 the overall state of the expression. */
1881 if (reverse
&& reverse
[n
] == GFC_REVERSE_SET
1882 && this_dep
== GFC_DEP_FORWARD
)
1884 reverse
[n
] = GFC_INHIBIT_REVERSE
;
1885 this_dep
= GFC_DEP_OVERLAP
;
1887 else if (reverse
&& reverse
[n
] == GFC_FORWARD_SET
1888 && this_dep
== GFC_DEP_BACKWARD
)
1890 reverse
[n
] = GFC_INHIBIT_REVERSE
;
1891 this_dep
= GFC_DEP_OVERLAP
;
1894 /* If no intention of reversing or reversing is explicitly
1895 inhibited, convert backward dependence to overlap. */
1896 if ((reverse
== NULL
&& this_dep
== GFC_DEP_BACKWARD
)
1897 || (reverse
!= NULL
&& reverse
[n
] == GFC_INHIBIT_REVERSE
))
1898 this_dep
= GFC_DEP_OVERLAP
;
1901 /* Overlap codes are in order of priority. We only need to
1902 know the worst one.*/
1903 if (this_dep
> fin_dep
)
1907 /* If this is an equal element, we have to keep going until we find
1908 the "real" array reference. */
1909 if (lref
->u
.ar
.type
== AR_ELEMENT
1910 && rref
->u
.ar
.type
== AR_ELEMENT
1911 && fin_dep
== GFC_DEP_EQUAL
)
1914 /* Exactly matching and forward overlapping ranges don't cause a
1916 if (fin_dep
< GFC_DEP_BACKWARD
)
1919 /* Keep checking. We only have a dependency if
1920 subsequent references also overlap. */
1930 /* If we haven't seen any array refs then something went wrong. */
1931 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
1933 /* Assume the worst if we nest to different depths. */
1937 return fin_dep
== GFC_DEP_OVERLAP
;