2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
21 /* dependency.c -- Expression dependency analysis code. */
22 /* There's probably quite a bit of duplication in this file. We currently
23 have different dependency checking functions for different types
24 if dependencies. Ideally these would probably be merged. */
28 #include "coretypes.h"
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 are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
126 if (e1
->symtree
->n
.sym
->attr
.dummy
&& e2
->symtree
->n
.sym
->attr
.dummy
)
128 /* Dummy arguments: Only check for equal names. */
129 if (e1
->symtree
->n
.sym
->name
!= e2
->symtree
->n
.sym
->name
)
134 /* Check for equal symbols. */
135 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
139 /* Volatile variables should never compare equal to themselves. */
141 if (e1
->symtree
->n
.sym
->attr
.volatile_
)
147 while (r1
!= NULL
|| r2
!= NULL
)
150 /* Assume the variables are not equal if one has a reference and the
152 TODO: Handle full references like comparing a(:) to a.
155 if (r1
== NULL
|| r2
== NULL
)
158 if (r1
->type
!= r2
->type
)
165 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
171 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
176 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0)
179 /* If both are NULL, the end length compares equal, because we
180 are looking at the same variable. This can only happen for
181 assumed- or deferred-length character arguments. */
183 if (r1
->u
.ss
.end
== NULL
&& r2
->u
.ss
.end
== NULL
)
186 if (gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
192 gfc_internal_error ("are_identical_variables: Bad type");
200 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
201 impure_ok is false, only return 0 for pure functions. */
204 gfc_dep_compare_functions (gfc_expr
*e1
, gfc_expr
*e2
, bool impure_ok
)
207 gfc_actual_arglist
*args1
;
208 gfc_actual_arglist
*args2
;
210 if (e1
->expr_type
!= EXPR_FUNCTION
|| e2
->expr_type
!= EXPR_FUNCTION
)
213 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
214 && e1
->value
.function
.esym
== e2
->value
.function
.esym
215 && (e1
->value
.function
.esym
->result
->attr
.pure
|| impure_ok
))
216 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
217 && e1
->value
.function
.isym
== e2
->value
.function
.isym
218 && (e1
->value
.function
.isym
->pure
|| impure_ok
)))
220 args1
= e1
->value
.function
.actual
;
221 args2
= e2
->value
.function
.actual
;
223 /* Compare the argument lists for equality. */
224 while (args1
&& args2
)
226 /* Bitwise xor, since C has no non-bitwise xor operator. */
227 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
230 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
231 && gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
237 return (args1
|| args2
) ? -2 : 0;
243 /* Helper function to look through parens, unary plus and widening
244 integer conversions. */
247 discard_nops (gfc_expr
*e
)
249 gfc_actual_arglist
*arglist
;
256 if (e
->expr_type
== EXPR_OP
257 && (e
->value
.op
.op
== INTRINSIC_UPLUS
258 || e
->value
.op
.op
== INTRINSIC_PARENTHESES
))
264 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
265 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
266 && e
->ts
.type
== BT_INTEGER
)
268 arglist
= e
->value
.function
.actual
;
269 if (arglist
->expr
->ts
.type
== BT_INTEGER
270 && e
->ts
.kind
> arglist
->expr
->ts
.kind
)
283 /* Compare two expressions. Return values:
287 * -2 if the relationship could not be determined
288 * -3 if e1 /= e2, but we cannot tell which one is larger.
289 REAL and COMPLEX constants are only compared for equality
290 or inequality; if they are unequal, -2 is returned in all cases. */
293 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
297 if (e1
== NULL
&& e2
== NULL
)
300 e1
= discard_nops (e1
);
301 e2
= discard_nops (e2
);
303 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
305 /* Compare X+C vs. X, for INTEGER only. */
306 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
307 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
308 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
309 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
311 /* Compare P+Q vs. R+S. */
312 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
316 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
317 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
318 if (l
== 0 && r
== 0)
320 if (l
== 0 && r
> -2)
322 if (l
> -2 && r
== 0)
324 if (l
== 1 && r
== 1)
326 if (l
== -1 && r
== -1)
329 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
330 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
331 if (l
== 0 && r
== 0)
333 if (l
== 0 && r
> -2)
335 if (l
> -2 && r
== 0)
337 if (l
== 1 && r
== 1)
339 if (l
== -1 && r
== -1)
344 /* Compare X vs. X+C, for INTEGER only. */
345 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
347 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
348 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
349 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
350 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
353 /* Compare X-C vs. X, for INTEGER only. */
354 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
356 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
357 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
358 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
359 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
361 /* Compare P-Q vs. R-S. */
362 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
366 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
367 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
368 if (l
== 0 && r
== 0)
370 if (l
> -2 && r
== 0)
372 if (l
== 0 && r
> -2)
374 if (l
== 1 && r
== -1)
376 if (l
== -1 && r
== 1)
381 /* Compare A // B vs. C // D. */
383 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_CONCAT
384 && e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_CONCAT
)
388 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
389 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
394 /* Left expressions of // compare equal, but
395 watch out for 'A ' // x vs. 'A' // x. */
396 gfc_expr
*e1_left
= e1
->value
.op
.op1
;
397 gfc_expr
*e2_left
= e2
->value
.op
.op1
;
399 if (e1_left
->expr_type
== EXPR_CONSTANT
400 && e2_left
->expr_type
== EXPR_CONSTANT
401 && e1_left
->value
.character
.length
402 != e2_left
->value
.character
.length
)
408 /* Compare X vs. X-C, for INTEGER only. */
409 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
411 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
412 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
413 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
414 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
417 if (e1
->expr_type
!= e2
->expr_type
)
420 switch (e1
->expr_type
)
423 /* Compare strings for equality. */
424 if (e1
->ts
.type
== BT_CHARACTER
&& e2
->ts
.type
== BT_CHARACTER
)
425 return gfc_compare_string (e1
, e2
);
427 /* Compare REAL and COMPLEX constants. Because of the
428 traps and pitfalls associated with comparing
429 a + 1.0 with a + 0.5, check for equality only. */
430 if (e2
->expr_type
== EXPR_CONSTANT
)
432 if (e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
)
434 if (mpfr_cmp (e1
->value
.real
, e2
->value
.real
) == 0)
439 else if (e1
->ts
.type
== BT_COMPLEX
&& e2
->ts
.type
== BT_COMPLEX
)
441 if (mpc_cmp (e1
->value
.complex, e2
->value
.complex) == 0)
448 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
451 /* For INTEGER, all cases where e2 is not constant should have
452 been filtered out above. */
453 gcc_assert (e2
->expr_type
== EXPR_CONSTANT
);
455 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
463 if (are_identical_variables (e1
, e2
))
469 /* Intrinsic operators are the same if their operands are the same. */
470 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
472 if (e1
->value
.op
.op2
== 0)
474 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
475 return i
== 0 ? 0 : -2;
477 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
478 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
480 else if (e1
->value
.op
.op
== INTRINSIC_TIMES
481 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
) == 0
482 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
) == 0)
483 /* Commutativity of multiplication; addition is handled above. */
489 return gfc_dep_compare_functions (e1
, e2
, false);
498 /* Return the difference between two expressions. Integer expressions of
501 X + constant, X - constant and constant + X
503 are handled. Return true on success, false on failure. result is assumed
504 to be uninitialized on entry, and will be initialized on success.
508 gfc_dep_difference (gfc_expr
*e1
, gfc_expr
*e2
, mpz_t
*result
)
510 gfc_expr
*e1_op1
, *e1_op2
, *e2_op1
, *e2_op2
;
512 if (e1
== NULL
|| e2
== NULL
)
515 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
518 e1
= discard_nops (e1
);
519 e2
= discard_nops (e2
);
521 /* Inizialize tentatively, clear if we don't return anything. */
524 /* Case 1: c1 - c2 = c1 - c2, trivially. */
526 if (e1
->expr_type
== EXPR_CONSTANT
&& e2
->expr_type
== EXPR_CONSTANT
)
528 mpz_sub (*result
, e1
->value
.integer
, e2
->value
.integer
);
532 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
534 e1_op1
= discard_nops (e1
->value
.op
.op1
);
535 e1_op2
= discard_nops (e1
->value
.op
.op2
);
537 /* Case 2: (X + c1) - X = c1. */
538 if (e1_op2
->expr_type
== EXPR_CONSTANT
539 && gfc_dep_compare_expr (e1_op1
, e2
) == 0)
541 mpz_set (*result
, e1_op2
->value
.integer
);
545 /* Case 3: (c1 + X) - X = c1. */
546 if (e1_op1
->expr_type
== EXPR_CONSTANT
547 && gfc_dep_compare_expr (e1_op2
, e2
) == 0)
549 mpz_set (*result
, e1_op1
->value
.integer
);
553 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
555 e2_op1
= discard_nops (e2
->value
.op
.op1
);
556 e2_op2
= discard_nops (e2
->value
.op
.op2
);
558 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
560 /* Case 4: X + c1 - (X + c2) = c1 - c2. */
561 if (e2_op2
->expr_type
== EXPR_CONSTANT
562 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
564 mpz_sub (*result
, e1_op2
->value
.integer
,
565 e2_op2
->value
.integer
);
568 /* Case 5: X + c1 - (c2 + X) = c1 - c2. */
569 if (e2_op1
->expr_type
== EXPR_CONSTANT
570 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
572 mpz_sub (*result
, e1_op2
->value
.integer
,
573 e2_op1
->value
.integer
);
577 else if (e1_op1
->expr_type
== EXPR_CONSTANT
)
579 /* Case 6: c1 + X - (X + c2) = c1 - c2. */
580 if (e2_op2
->expr_type
== EXPR_CONSTANT
581 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
583 mpz_sub (*result
, e1_op1
->value
.integer
,
584 e2_op2
->value
.integer
);
587 /* Case 7: c1 + X - (c2 + X) = c1 - c2. */
588 if (e2_op1
->expr_type
== EXPR_CONSTANT
589 && gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
591 mpz_sub (*result
, e1_op1
->value
.integer
,
592 e2_op1
->value
.integer
);
598 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
600 e2_op1
= discard_nops (e2
->value
.op
.op1
);
601 e2_op2
= discard_nops (e2
->value
.op
.op2
);
603 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
605 /* Case 8: X + c1 - (X - c2) = c1 + c2. */
606 if (e2_op2
->expr_type
== EXPR_CONSTANT
607 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
609 mpz_add (*result
, e1_op2
->value
.integer
,
610 e2_op2
->value
.integer
);
614 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
616 /* Case 9: c1 + X - (X - c2) = c1 + c2. */
617 if (e2_op2
->expr_type
== EXPR_CONSTANT
618 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
620 mpz_add (*result
, e1_op1
->value
.integer
,
621 e2_op2
->value
.integer
);
628 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
630 e1_op1
= discard_nops (e1
->value
.op
.op1
);
631 e1_op2
= discard_nops (e1
->value
.op
.op2
);
633 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
635 /* Case 10: (X - c1) - X = -c1 */
637 if (gfc_dep_compare_expr (e1_op1
, e2
) == 0)
639 mpz_neg (*result
, e1_op2
->value
.integer
);
643 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
645 e2_op1
= discard_nops (e2
->value
.op
.op1
);
646 e2_op2
= discard_nops (e2
->value
.op
.op2
);
648 /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
649 if (e2_op2
->expr_type
== EXPR_CONSTANT
650 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
652 mpz_add (*result
, e1_op2
->value
.integer
,
653 e2_op2
->value
.integer
);
654 mpz_neg (*result
, *result
);
658 /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
659 if (e2_op1
->expr_type
== EXPR_CONSTANT
660 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
662 mpz_add (*result
, e1_op2
->value
.integer
,
663 e2_op1
->value
.integer
);
664 mpz_neg (*result
, *result
);
669 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
671 e2_op1
= discard_nops (e2
->value
.op
.op1
);
672 e2_op2
= discard_nops (e2
->value
.op
.op2
);
674 /* Case 13: (X - c1) - (X - c2) = c2 - c1. */
675 if (e2_op2
->expr_type
== EXPR_CONSTANT
676 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
678 mpz_sub (*result
, e2_op2
->value
.integer
,
679 e1_op2
->value
.integer
);
684 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
686 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
688 e2_op1
= discard_nops (e2
->value
.op
.op1
);
689 e2_op2
= discard_nops (e2
->value
.op
.op2
);
691 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
692 if (gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
694 mpz_sub (*result
, e1_op1
->value
.integer
,
695 e2_op1
->value
.integer
);
703 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
705 e2_op1
= discard_nops (e2
->value
.op
.op1
);
706 e2_op2
= discard_nops (e2
->value
.op
.op2
);
708 /* Case 15: X - (X + c2) = -c2. */
709 if (e2_op2
->expr_type
== EXPR_CONSTANT
710 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
712 mpz_neg (*result
, e2_op2
->value
.integer
);
715 /* Case 16: X - (c2 + X) = -c2. */
716 if (e2_op1
->expr_type
== EXPR_CONSTANT
717 && gfc_dep_compare_expr (e1
, e2_op2
) == 0)
719 mpz_neg (*result
, e2_op1
->value
.integer
);
724 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
726 e2_op1
= discard_nops (e2
->value
.op
.op1
);
727 e2_op2
= discard_nops (e2
->value
.op
.op2
);
729 /* Case 17: X - (X - c2) = c2. */
730 if (e2_op2
->expr_type
== EXPR_CONSTANT
731 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
733 mpz_set (*result
, e2_op2
->value
.integer
);
738 if (gfc_dep_compare_expr (e1
, e2
) == 0)
740 /* Case 18: X - X = 0. */
741 mpz_set_si (*result
, 0);
749 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
750 results are indeterminate). 'n' is the dimension to compare. */
753 is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
)
759 /* TODO: More sophisticated range comparison. */
760 gcc_assert (ar1
&& ar2
);
762 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
766 /* Check for mismatching strides. A NULL stride means a stride of 1. */
769 i
= gfc_expr_is_one (e1
, -1);
770 if (i
== -1 || i
== 0)
775 i
= gfc_expr_is_one (e2
, -1);
776 if (i
== -1 || i
== 0)
781 i
= gfc_dep_compare_expr (e1
, e2
);
785 /* The strides match. */
787 /* Check the range start. */
792 /* Use the bound of the array if no bound is specified. */
794 e1
= ar1
->as
->lower
[n
];
797 e2
= ar2
->as
->lower
[n
];
799 /* Check we have values for both. */
803 i
= gfc_dep_compare_expr (e1
, e2
);
808 /* Check the range end. */
813 /* Use the bound of the array if no bound is specified. */
815 e1
= ar1
->as
->upper
[n
];
818 e2
= ar2
->as
->upper
[n
];
820 /* Check we have values for both. */
824 i
= gfc_dep_compare_expr (e1
, e2
);
833 /* Some array-returning intrinsics can be implemented by reusing the
834 data from one of the array arguments. For example, TRANSPOSE does
835 not necessarily need to allocate new data: it can be implemented
836 by copying the original array's descriptor and simply swapping the
837 two dimension specifications.
839 If EXPR is a call to such an intrinsic, return the argument
840 whose data can be reused, otherwise return NULL. */
843 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
845 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
848 switch (expr
->value
.function
.isym
->id
)
850 case GFC_ISYM_TRANSPOSE
:
851 return expr
->value
.function
.actual
->expr
;
859 /* Return true if the result of reference REF can only be constructed
860 using a temporary array. */
863 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
869 for (; ref
; ref
= ref
->next
)
873 /* Vector dimensions are generally not monotonic and must be
874 handled using a temporary. */
875 if (ref
->u
.ar
.type
== AR_SECTION
)
876 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
877 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
884 /* Within an array reference, character substrings generally
885 need a temporary. Character array strides are expressed as
886 multiples of the element size (consistent with other array
887 types), not in characters. */
899 gfc_is_data_pointer (gfc_expr
*e
)
903 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
906 /* No subreference if it is a function */
907 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
909 if (e
->symtree
->n
.sym
->attr
.pointer
)
912 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
913 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
920 /* Return true if array variable VAR could be passed to the same function
921 as argument EXPR without interfering with EXPR. INTENT is the intent
924 This is considerably less conservative than other dependencies
925 because many function arguments will already be copied into a
929 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
930 gfc_expr
*expr
, gfc_dep_check elemental
)
934 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
935 gcc_assert (var
->rank
> 0);
937 switch (expr
->expr_type
)
940 /* In case of elemental subroutines, there is no dependency
941 between two same-range array references. */
942 if (gfc_ref_needs_temporary_p (expr
->ref
)
943 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
945 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
947 /* Too many false positive with pointers. */
948 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
950 /* Elemental procedures forbid unspecified intents,
951 and we don't check dependencies for INTENT_IN args. */
952 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
954 /* We are told not to check dependencies.
955 We do it, however, and issue a warning in case we find one.
956 If a dependency is found in the case
957 elemental == ELEM_CHECK_VARIABLE, we will generate
958 a temporary, so we don't need to bother the user. */
959 gfc_warning ("INTENT(%s) actual argument at %L might "
960 "interfere with actual argument at %L.",
961 intent
== INTENT_OUT
? "OUT" : "INOUT",
962 &var
->where
, &expr
->where
);
972 /* the scalarizer always generates a temporary for array constructors,
973 so there is no dependency. */
977 if (intent
!= INTENT_IN
)
979 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
981 return gfc_check_argument_var_dependency (var
, intent
, arg
,
985 if (elemental
!= NOT_ELEMENTAL
)
987 if ((expr
->value
.function
.esym
988 && expr
->value
.function
.esym
->attr
.elemental
)
989 || (expr
->value
.function
.isym
990 && expr
->value
.function
.isym
->elemental
))
991 return gfc_check_fncall_dependency (var
, intent
, NULL
,
992 expr
->value
.function
.actual
,
993 ELEM_CHECK_VARIABLE
);
995 if (gfc_inline_intrinsic_function_p (expr
))
997 /* The TRANSPOSE case should have been caught in the
998 noncopying intrinsic case above. */
999 gcc_assert (expr
->value
.function
.isym
->id
!= GFC_ISYM_TRANSPOSE
);
1001 return gfc_check_fncall_dependency (var
, intent
, NULL
,
1002 expr
->value
.function
.actual
,
1003 ELEM_CHECK_VARIABLE
);
1009 /* In case of non-elemental procedures, there is no need to catch
1010 dependencies, as we will make a temporary anyway. */
1013 /* If the actual arg EXPR is an expression, we need to catch
1014 a dependency between variables in EXPR and VAR,
1015 an intent((IN)OUT) variable. */
1016 if (expr
->value
.op
.op1
1017 && gfc_check_argument_var_dependency (var
, intent
,
1019 ELEM_CHECK_VARIABLE
))
1021 else if (expr
->value
.op
.op2
1022 && gfc_check_argument_var_dependency (var
, intent
,
1024 ELEM_CHECK_VARIABLE
))
1035 /* Like gfc_check_argument_var_dependency, but extended to any
1036 array expression OTHER, not just variables. */
1039 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
1040 gfc_expr
*expr
, gfc_dep_check elemental
)
1042 switch (other
->expr_type
)
1045 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
1048 other
= gfc_get_noncopying_intrinsic_argument (other
);
1050 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
1061 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
1062 FNSYM is the function being called, or NULL if not known. */
1065 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
1066 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
1067 gfc_dep_check elemental
)
1069 gfc_formal_arglist
*formal
;
1072 formal
= fnsym
? gfc_sym_get_dummy_args (fnsym
) : NULL
;
1073 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
1075 expr
= actual
->expr
;
1077 /* Skip args which are not present. */
1081 /* Skip other itself. */
1085 /* Skip intent(in) arguments if OTHER itself is intent(in). */
1086 if (formal
&& intent
== INTENT_IN
1087 && formal
->sym
->attr
.intent
== INTENT_IN
)
1090 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
1098 /* Return 1 if e1 and e2 are equivalenced arrays, either
1099 directly or indirectly; i.e., equivalence (a,b) for a and b
1100 or equivalence (a,c),(b,c). This function uses the equiv_
1101 lists, generated in trans-common(add_equivalences), that are
1102 guaranteed to pick up indirect equivalences. We explicitly
1103 check for overlap using the offset and length of the equivalence.
1104 This function is symmetric.
1105 TODO: This function only checks whether the full top-level
1106 symbols overlap. An improved implementation could inspect
1107 e1->ref and e2->ref to determine whether the actually accessed
1108 portions of these variables/arrays potentially overlap. */
1111 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
1114 gfc_equiv_info
*s
, *fl1
, *fl2
;
1116 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
1117 && e2
->expr_type
== EXPR_VARIABLE
);
1119 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
1120 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
1123 if (e1
->symtree
->n
.sym
->ns
1124 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
1125 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
1127 l
= gfc_current_ns
->equiv_lists
;
1129 /* Go through the equiv_lists and return 1 if the variables
1130 e1 and e2 are members of the same group and satisfy the
1131 requirement on their relative offsets. */
1132 for (; l
; l
= l
->next
)
1136 for (s
= l
->equiv
; s
; s
= s
->next
)
1138 if (s
->sym
== e1
->symtree
->n
.sym
)
1144 if (s
->sym
== e2
->symtree
->n
.sym
)
1154 /* Can these lengths be zero? */
1155 if (fl1
->length
<= 0 || fl2
->length
<= 0)
1157 /* These can't overlap if [f11,fl1+length] is before
1158 [fl2,fl2+length], or [fl2,fl2+length] is before
1159 [fl1,fl1+length], otherwise they do overlap. */
1160 if (fl1
->offset
+ fl1
->length
> fl2
->offset
1161 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
1169 /* Return true if there is no possibility of aliasing because of a type
1170 mismatch between all the possible pointer references and the
1171 potential target. Note that this function is asymmetric in the
1172 arguments and so must be called twice with the arguments exchanged. */
1175 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
1181 bool seen_component_ref
;
1183 if (expr1
->expr_type
!= EXPR_VARIABLE
1184 || expr2
->expr_type
!= EXPR_VARIABLE
)
1187 sym1
= expr1
->symtree
->n
.sym
;
1188 sym2
= expr2
->symtree
->n
.sym
;
1190 /* Keep it simple for now. */
1191 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
1194 if (sym1
->attr
.pointer
)
1196 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
1200 /* This is a conservative check on the components of the derived type
1201 if no component references have been seen. Since we will not dig
1202 into the components of derived type components, we play it safe by
1203 returning false. First we check the reference chain and then, if
1204 no component references have been seen, the components. */
1205 seen_component_ref
= false;
1206 if (sym1
->ts
.type
== BT_DERIVED
)
1208 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
1210 if (ref1
->type
!= REF_COMPONENT
)
1213 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
1216 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
1217 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
1220 seen_component_ref
= true;
1224 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
1226 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
1228 if (cm1
->ts
.type
== BT_DERIVED
)
1231 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
1232 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
1241 /* Return true if the statement body redefines the condition. Returns
1242 true if expr2 depends on expr1. expr1 should be a single term
1243 suitable for the lhs of an assignment. The IDENTICAL flag indicates
1244 whether array references to the same symbol with identical range
1245 references count as a dependency or not. Used for forall and where
1246 statements. Also used with functions returning arrays without a
1250 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
1252 gfc_actual_arglist
*actual
;
1256 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1258 switch (expr2
->expr_type
)
1261 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
1264 if (expr2
->value
.op
.op2
)
1265 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
1269 /* The interesting cases are when the symbols don't match. */
1270 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
1272 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
1273 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
1275 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1276 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
1279 /* Symbols can only alias if they have the same type. */
1280 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
1281 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
1283 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
1287 /* If either variable is a pointer, assume the worst. */
1288 /* TODO: -fassume-no-pointer-aliasing */
1289 if (gfc_is_data_pointer (expr1
) || gfc_is_data_pointer (expr2
))
1291 if (check_data_pointer_types (expr1
, expr2
)
1292 && check_data_pointer_types (expr2
, expr1
))
1299 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
1300 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
1301 if (sym1
->attr
.target
&& sym2
->attr
.target
1302 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
1303 && (!sym1
->attr
.dimension
1304 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
1305 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
1306 && (!sym2
->attr
.dimension
1307 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
1311 /* Otherwise distinct symbols have no dependencies. */
1318 /* Identical and disjoint ranges return 0,
1319 overlapping ranges return 1. */
1320 if (expr1
->ref
&& expr2
->ref
)
1321 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
);
1326 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
1329 /* Remember possible differences between elemental and
1330 transformational functions. All functions inside a FORALL
1332 for (actual
= expr2
->value
.function
.actual
;
1333 actual
; actual
= actual
->next
)
1337 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
1348 /* Loop through the array constructor's elements. */
1349 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
1350 c
; c
= gfc_constructor_next (c
))
1352 /* If this is an iterator, assume the worst. */
1355 /* Avoid recursion in the common case. */
1356 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1358 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1369 /* Determines overlapping for two array sections. */
1371 static gfc_dependency
1372 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1388 int stride_comparison
;
1389 int start_comparison
;
1392 /* If they are the same range, return without more ado. */
1393 if (is_same_range (l_ar
, r_ar
, n
))
1394 return GFC_DEP_EQUAL
;
1396 l_start
= l_ar
->start
[n
];
1397 l_end
= l_ar
->end
[n
];
1398 l_stride
= l_ar
->stride
[n
];
1400 r_start
= r_ar
->start
[n
];
1401 r_end
= r_ar
->end
[n
];
1402 r_stride
= r_ar
->stride
[n
];
1404 /* If l_start is NULL take it from array specifier. */
1405 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1406 l_start
= l_ar
->as
->lower
[n
];
1407 /* If l_end is NULL take it from array specifier. */
1408 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1409 l_end
= l_ar
->as
->upper
[n
];
1411 /* If r_start is NULL take it from array specifier. */
1412 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1413 r_start
= r_ar
->as
->lower
[n
];
1414 /* If r_end is NULL take it from array specifier. */
1415 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1416 r_end
= r_ar
->as
->upper
[n
];
1418 /* Determine whether the l_stride is positive or negative. */
1421 else if (l_stride
->expr_type
== EXPR_CONSTANT
1422 && l_stride
->ts
.type
== BT_INTEGER
)
1423 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1424 else if (l_start
&& l_end
)
1425 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1429 /* Determine whether the r_stride is positive or negative. */
1432 else if (r_stride
->expr_type
== EXPR_CONSTANT
1433 && r_stride
->ts
.type
== BT_INTEGER
)
1434 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1435 else if (r_start
&& r_end
)
1436 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1440 /* The strides should never be zero. */
1441 if (l_dir
== 0 || r_dir
== 0)
1442 return GFC_DEP_OVERLAP
;
1444 /* Determine the relationship between the strides. Set stride_comparison to
1445 -2 if the dependency cannot be determined
1446 -1 if l_stride < r_stride
1447 0 if l_stride == r_stride
1448 1 if l_stride > r_stride
1449 as determined by gfc_dep_compare_expr. */
1451 one_expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1453 stride_comparison
= gfc_dep_compare_expr (l_stride
? l_stride
: one_expr
,
1454 r_stride
? r_stride
: one_expr
);
1456 if (l_start
&& r_start
)
1457 start_comparison
= gfc_dep_compare_expr (l_start
, r_start
);
1459 start_comparison
= -2;
1461 gfc_free_expr (one_expr
);
1463 /* Determine LHS upper and lower bounds. */
1469 else if (l_dir
== -1)
1480 /* Determine RHS upper and lower bounds. */
1486 else if (r_dir
== -1)
1497 /* Check whether the ranges are disjoint. */
1498 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1499 return GFC_DEP_NODEP
;
1500 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1501 return GFC_DEP_NODEP
;
1503 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1504 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1506 if (l_dir
== 1 && r_dir
== -1)
1507 return GFC_DEP_EQUAL
;
1508 if (l_dir
== -1 && r_dir
== 1)
1509 return GFC_DEP_EQUAL
;
1512 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1513 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1515 if (l_dir
== 1 && r_dir
== -1)
1516 return GFC_DEP_EQUAL
;
1517 if (l_dir
== -1 && r_dir
== 1)
1518 return GFC_DEP_EQUAL
;
1521 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1522 There is no dependency if the remainder of
1523 (l_start - r_start) / gcd(l_stride, r_stride) is
1526 - Cases like a(1:4:2) = a(2:3) are still not handled.
1529 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1530 && (a)->ts.type == BT_INTEGER)
1532 if (IS_CONSTANT_INTEGER (l_stride
) && IS_CONSTANT_INTEGER (r_stride
)
1533 && gfc_dep_difference (l_start
, r_start
, &tmp
))
1539 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1541 mpz_fdiv_r (tmp
, tmp
, gcd
);
1542 result
= mpz_cmp_si (tmp
, 0L);
1548 return GFC_DEP_NODEP
;
1551 #undef IS_CONSTANT_INTEGER
1553 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1555 if (l_dir
== 1 && r_dir
== 1 &&
1556 (start_comparison
== 0 || start_comparison
== -1)
1557 && (stride_comparison
== 0 || stride_comparison
== -1))
1558 return GFC_DEP_FORWARD
;
1560 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1561 x:y:-1 vs. x:y:-2. */
1562 if (l_dir
== -1 && r_dir
== -1 &&
1563 (start_comparison
== 0 || start_comparison
== 1)
1564 && (stride_comparison
== 0 || stride_comparison
== 1))
1565 return GFC_DEP_FORWARD
;
1567 if (stride_comparison
== 0 || stride_comparison
== -1)
1569 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1572 /* Check for a(low:y:s) vs. a(z:x:s) or
1573 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1574 of low, which is always at least a forward dependence. */
1577 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1578 return GFC_DEP_FORWARD
;
1582 if (stride_comparison
== 0 || stride_comparison
== 1)
1584 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1587 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1588 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1589 of high, which is always at least a forward dependence. */
1592 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1593 return GFC_DEP_FORWARD
;
1598 if (stride_comparison
== 0)
1600 /* From here, check for backwards dependencies. */
1601 /* x+1:y vs. x:z. */
1602 if (l_dir
== 1 && r_dir
== 1 && start_comparison
== 1)
1603 return GFC_DEP_BACKWARD
;
1605 /* x-1:y:-1 vs. x:z:-1. */
1606 if (l_dir
== -1 && r_dir
== -1 && start_comparison
== -1)
1607 return GFC_DEP_BACKWARD
;
1610 return GFC_DEP_OVERLAP
;
1614 /* Determines overlapping for a single element and a section. */
1616 static gfc_dependency
1617 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1626 elem
= lref
->u
.ar
.start
[n
];
1628 return GFC_DEP_OVERLAP
;
1631 start
= ref
->start
[n
] ;
1633 stride
= ref
->stride
[n
];
1635 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1636 start
= ref
->as
->lower
[n
];
1637 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1638 end
= ref
->as
->upper
[n
];
1640 /* Determine whether the stride is positive or negative. */
1643 else if (stride
->expr_type
== EXPR_CONSTANT
1644 && stride
->ts
.type
== BT_INTEGER
)
1645 s
= mpz_sgn (stride
->value
.integer
);
1649 /* Stride should never be zero. */
1651 return GFC_DEP_OVERLAP
;
1653 /* Positive strides. */
1656 /* Check for elem < lower. */
1657 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1658 return GFC_DEP_NODEP
;
1659 /* Check for elem > upper. */
1660 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1661 return GFC_DEP_NODEP
;
1665 s
= gfc_dep_compare_expr (start
, end
);
1666 /* Check for an empty range. */
1668 return GFC_DEP_NODEP
;
1669 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1670 return GFC_DEP_EQUAL
;
1673 /* Negative strides. */
1676 /* Check for elem > upper. */
1677 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1678 return GFC_DEP_NODEP
;
1679 /* Check for elem < lower. */
1680 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1681 return GFC_DEP_NODEP
;
1685 s
= gfc_dep_compare_expr (start
, end
);
1686 /* Check for an empty range. */
1688 return GFC_DEP_NODEP
;
1689 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1690 return GFC_DEP_EQUAL
;
1693 /* Unknown strides. */
1697 return GFC_DEP_OVERLAP
;
1698 s
= gfc_dep_compare_expr (start
, end
);
1700 return GFC_DEP_OVERLAP
;
1701 /* Assume positive stride. */
1704 /* Check for elem < lower. */
1705 if (gfc_dep_compare_expr (elem
, start
) == -1)
1706 return GFC_DEP_NODEP
;
1707 /* Check for elem > upper. */
1708 if (gfc_dep_compare_expr (elem
, end
) == 1)
1709 return GFC_DEP_NODEP
;
1711 /* Assume negative stride. */
1714 /* Check for elem > upper. */
1715 if (gfc_dep_compare_expr (elem
, start
) == 1)
1716 return GFC_DEP_NODEP
;
1717 /* Check for elem < lower. */
1718 if (gfc_dep_compare_expr (elem
, end
) == -1)
1719 return GFC_DEP_NODEP
;
1724 s
= gfc_dep_compare_expr (elem
, start
);
1726 return GFC_DEP_EQUAL
;
1727 if (s
== 1 || s
== -1)
1728 return GFC_DEP_NODEP
;
1732 return GFC_DEP_OVERLAP
;
1736 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1737 forall_index attribute. Return true if any variable may be
1738 being used as a FORALL index. Its safe to pessimistically
1739 return true, and assume a dependency. */
1742 contains_forall_index_p (gfc_expr
*expr
)
1744 gfc_actual_arglist
*arg
;
1752 switch (expr
->expr_type
)
1755 if (expr
->symtree
->n
.sym
->forall_index
)
1760 if (contains_forall_index_p (expr
->value
.op
.op1
)
1761 || contains_forall_index_p (expr
->value
.op
.op2
))
1766 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1767 if (contains_forall_index_p (arg
->expr
))
1773 case EXPR_SUBSTRING
:
1776 case EXPR_STRUCTURE
:
1778 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1779 c
; gfc_constructor_next (c
))
1780 if (contains_forall_index_p (c
->expr
))
1788 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1792 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1793 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1794 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1795 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1803 if (contains_forall_index_p (ref
->u
.ss
.start
)
1804 || contains_forall_index_p (ref
->u
.ss
.end
))
1815 /* Determines overlapping for two single element array references. */
1817 static gfc_dependency
1818 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1828 l_start
= l_ar
.start
[n
] ;
1829 r_start
= r_ar
.start
[n
] ;
1830 i
= gfc_dep_compare_expr (r_start
, l_start
);
1832 return GFC_DEP_EQUAL
;
1834 /* Treat two scalar variables as potentially equal. This allows
1835 us to prove that a(i,:) and a(j,:) have no dependency. See
1836 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1837 Proceedings of the International Conference on Parallel and
1838 Distributed Processing Techniques and Applications (PDPTA2001),
1839 Las Vegas, Nevada, June 2001. */
1840 /* However, we need to be careful when either scalar expression
1841 contains a FORALL index, as these can potentially change value
1842 during the scalarization/traversal of this array reference. */
1843 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1844 return GFC_DEP_OVERLAP
;
1847 return GFC_DEP_NODEP
;
1848 return GFC_DEP_EQUAL
;
1852 /* Determine if an array ref, usually an array section specifies the
1853 entire array. In addition, if the second, pointer argument is
1854 provided, the function will return true if the reference is
1855 contiguous; eg. (:, 1) gives true but (1,:) gives false. */
1858 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1862 bool lbound_OK
= true;
1863 bool ubound_OK
= true;
1866 *contiguous
= false;
1868 if (ref
->type
!= REF_ARRAY
)
1871 if (ref
->u
.ar
.type
== AR_FULL
)
1878 if (ref
->u
.ar
.type
!= AR_SECTION
)
1883 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1885 /* If we have a single element in the reference, for the reference
1886 to be full, we need to ascertain that the array has a single
1887 element in this dimension and that we actually reference the
1889 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1891 /* This is unconditionally a contiguous reference if all the
1892 remaining dimensions are elements. */
1896 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1897 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1898 *contiguous
= false;
1902 || !ref
->u
.ar
.as
->lower
[i
]
1903 || !ref
->u
.ar
.as
->upper
[i
]
1904 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1905 ref
->u
.ar
.as
->upper
[i
])
1906 || !ref
->u
.ar
.start
[i
]
1907 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1908 ref
->u
.ar
.as
->lower
[i
]))
1914 /* Check the lower bound. */
1915 if (ref
->u
.ar
.start
[i
]
1917 || !ref
->u
.ar
.as
->lower
[i
]
1918 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1919 ref
->u
.ar
.as
->lower
[i
])))
1921 /* Check the upper bound. */
1922 if (ref
->u
.ar
.end
[i
]
1924 || !ref
->u
.ar
.as
->upper
[i
]
1925 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1926 ref
->u
.ar
.as
->upper
[i
])))
1928 /* Check the stride. */
1929 if (ref
->u
.ar
.stride
[i
]
1930 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1933 /* This is unconditionally a contiguous reference as long as all
1934 the subsequent dimensions are elements. */
1938 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1939 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1940 *contiguous
= false;
1943 if (!lbound_OK
|| !ubound_OK
)
1950 /* Determine if a full array is the same as an array section with one
1951 variable limit. For this to be so, the strides must both be unity
1952 and one of either start == lower or end == upper must be true. */
1955 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1958 bool upper_or_lower
;
1960 if (full_ref
->type
!= REF_ARRAY
)
1962 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1964 if (ref
->type
!= REF_ARRAY
)
1966 if (ref
->u
.ar
.type
!= AR_SECTION
)
1969 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1971 /* If we have a single element in the reference, we need to check
1972 that the array has a single element and that we actually reference
1973 the correct element. */
1974 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1976 if (!full_ref
->u
.ar
.as
1977 || !full_ref
->u
.ar
.as
->lower
[i
]
1978 || !full_ref
->u
.ar
.as
->upper
[i
]
1979 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
1980 full_ref
->u
.ar
.as
->upper
[i
])
1981 || !ref
->u
.ar
.start
[i
]
1982 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1983 full_ref
->u
.ar
.as
->lower
[i
]))
1987 /* Check the strides. */
1988 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
1990 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1993 upper_or_lower
= false;
1994 /* Check the lower bound. */
1995 if (ref
->u
.ar
.start
[i
]
1997 && full_ref
->u
.ar
.as
->lower
[i
]
1998 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1999 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
2000 upper_or_lower
= true;
2001 /* Check the upper bound. */
2002 if (ref
->u
.ar
.end
[i
]
2004 && full_ref
->u
.ar
.as
->upper
[i
]
2005 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
2006 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
2007 upper_or_lower
= true;
2008 if (!upper_or_lower
)
2015 /* Finds if two array references are overlapping or not.
2017 2 : array references are overlapping but reversal of one or
2018 more dimensions will clear the dependency.
2019 1 : array references are overlapping.
2020 0 : array references are identical or not overlapping. */
2023 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
)
2026 gfc_dependency fin_dep
;
2027 gfc_dependency this_dep
;
2029 this_dep
= GFC_DEP_ERROR
;
2030 fin_dep
= GFC_DEP_ERROR
;
2031 /* Dependencies due to pointers should already have been identified.
2032 We only need to check for overlapping array references. */
2034 while (lref
&& rref
)
2036 /* We're resolving from the same base symbol, so both refs should be
2037 the same type. We traverse the reference chain until we find ranges
2038 that are not equal. */
2039 gcc_assert (lref
->type
== rref
->type
);
2043 /* The two ranges can't overlap if they are from different
2045 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
2050 /* Substring overlaps are handled by the string assignment code
2051 if there is not an underlying dependency. */
2052 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
2056 if (ref_same_as_full_array (lref
, rref
))
2059 if (ref_same_as_full_array (rref
, lref
))
2062 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
2064 if (lref
->u
.ar
.type
== AR_FULL
)
2065 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
2067 else if (rref
->u
.ar
.type
== AR_FULL
)
2068 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
2075 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
2077 /* Handle dependency when either of array reference is vector
2078 subscript. There is no dependency if the vector indices
2079 are equal or if indices are known to be different in a
2080 different dimension. */
2081 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2082 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2084 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2085 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2086 && gfc_dep_compare_expr (lref
->u
.ar
.start
[n
],
2087 rref
->u
.ar
.start
[n
]) == 0)
2088 this_dep
= GFC_DEP_EQUAL
;
2090 this_dep
= GFC_DEP_OVERLAP
;
2092 goto update_fin_dep
;
2095 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2096 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2097 this_dep
= check_section_vs_section (&lref
->u
.ar
, &rref
->u
.ar
, n
);
2098 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2099 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2100 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
2101 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2102 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2103 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
2106 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2107 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
2108 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
2111 /* If any dimension doesn't overlap, we have no dependency. */
2112 if (this_dep
== GFC_DEP_NODEP
)
2115 /* Now deal with the loop reversal logic: This only works on
2116 ranges and is activated by setting
2117 reverse[n] == GFC_ENABLE_REVERSE
2118 The ability to reverse or not is set by previous conditions
2119 in this dimension. If reversal is not activated, the
2120 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2121 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2122 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2124 /* Set reverse if backward dependence and not inhibited. */
2125 if (reverse
&& reverse
[n
] == GFC_ENABLE_REVERSE
)
2126 reverse
[n
] = (this_dep
== GFC_DEP_BACKWARD
) ?
2127 GFC_REVERSE_SET
: reverse
[n
];
2129 /* Set forward if forward dependence and not inhibited. */
2130 if (reverse
&& reverse
[n
] == GFC_ENABLE_REVERSE
)
2131 reverse
[n
] = (this_dep
== GFC_DEP_FORWARD
) ?
2132 GFC_FORWARD_SET
: reverse
[n
];
2134 /* Flag up overlap if dependence not compatible with
2135 the overall state of the expression. */
2136 if (reverse
&& reverse
[n
] == GFC_REVERSE_SET
2137 && this_dep
== GFC_DEP_FORWARD
)
2139 reverse
[n
] = GFC_INHIBIT_REVERSE
;
2140 this_dep
= GFC_DEP_OVERLAP
;
2142 else if (reverse
&& reverse
[n
] == GFC_FORWARD_SET
2143 && this_dep
== GFC_DEP_BACKWARD
)
2145 reverse
[n
] = GFC_INHIBIT_REVERSE
;
2146 this_dep
= GFC_DEP_OVERLAP
;
2149 /* If no intention of reversing or reversing is explicitly
2150 inhibited, convert backward dependence to overlap. */
2151 if ((reverse
== NULL
&& this_dep
== GFC_DEP_BACKWARD
)
2152 || (reverse
!= NULL
&& reverse
[n
] == GFC_INHIBIT_REVERSE
))
2153 this_dep
= GFC_DEP_OVERLAP
;
2156 /* Overlap codes are in order of priority. We only need to
2157 know the worst one.*/
2160 if (this_dep
> fin_dep
)
2164 /* If this is an equal element, we have to keep going until we find
2165 the "real" array reference. */
2166 if (lref
->u
.ar
.type
== AR_ELEMENT
2167 && rref
->u
.ar
.type
== AR_ELEMENT
2168 && fin_dep
== GFC_DEP_EQUAL
)
2171 /* Exactly matching and forward overlapping ranges don't cause a
2173 if (fin_dep
< GFC_DEP_BACKWARD
)
2176 /* Keep checking. We only have a dependency if
2177 subsequent references also overlap. */
2187 /* If we haven't seen any array refs then something went wrong. */
2188 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
2190 /* Assume the worst if we nest to different depths. */
2194 return fin_dep
== GFC_DEP_OVERLAP
;