2 Copyright (C) 2000-2023 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.cc -- 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"
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. */
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 if (a1
->dimen
!= a2
->dimen
)
106 gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
108 for (i
= 0; i
< a1
->dimen
; i
++)
110 if (gfc_dep_compare_expr (a1
->start
[i
], a2
->start
[i
]) != 0)
120 /* Return true for identical variables, checking for references if
121 necessary. Calls identical_array_ref for checking array sections. */
124 are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
128 if (e1
->symtree
->n
.sym
->attr
.dummy
&& e2
->symtree
->n
.sym
->attr
.dummy
)
130 /* Dummy arguments: Only check for equal names. */
131 if (e1
->symtree
->n
.sym
->name
!= e2
->symtree
->n
.sym
->name
)
136 /* Check for equal symbols. */
137 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
141 /* Volatile variables should never compare equal to themselves. */
143 if (e1
->symtree
->n
.sym
->attr
.volatile_
)
149 while (r1
!= NULL
|| r2
!= NULL
)
152 /* Assume the variables are not equal if one has a reference and the
154 TODO: Handle full references like comparing a(:) to a.
157 if (r1
== NULL
|| r2
== NULL
)
160 if (r1
->type
!= r2
->type
)
167 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
173 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
178 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0)
181 /* If both are NULL, the end length compares equal, because we
182 are looking at the same variable. This can only happen for
183 assumed- or deferred-length character arguments. */
185 if (r1
->u
.ss
.end
== NULL
&& r2
->u
.ss
.end
== NULL
)
188 if (gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
194 if (r1
->u
.i
!= r2
->u
.i
)
199 gfc_internal_error ("are_identical_variables: Bad type");
207 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
208 impure_ok is false, only return 0 for pure functions. */
211 gfc_dep_compare_functions (gfc_expr
*e1
, gfc_expr
*e2
, bool impure_ok
)
214 gfc_actual_arglist
*args1
;
215 gfc_actual_arglist
*args2
;
217 if (e1
->expr_type
!= EXPR_FUNCTION
|| e2
->expr_type
!= EXPR_FUNCTION
)
220 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
221 && e1
->value
.function
.esym
== e2
->value
.function
.esym
222 && (e1
->value
.function
.esym
->result
->attr
.pure
|| impure_ok
))
223 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
224 && e1
->value
.function
.isym
== e2
->value
.function
.isym
225 && (e1
->value
.function
.isym
->pure
|| impure_ok
)))
227 args1
= e1
->value
.function
.actual
;
228 args2
= e2
->value
.function
.actual
;
230 /* Compare the argument lists for equality. */
231 while (args1
&& args2
)
233 /* Bitwise xor, since C has no non-bitwise xor operator. */
234 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
237 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
)
243 if (gfc_dep_compare_expr (e1
, e2
) != 0)
246 /* Special case: String arguments which compare equal can have
247 different lengths, which makes them different in calls to
250 if (e1
->expr_type
== EXPR_CONSTANT
251 && e1
->ts
.type
== BT_CHARACTER
252 && e2
->expr_type
== EXPR_CONSTANT
253 && e2
->ts
.type
== BT_CHARACTER
254 && e1
->value
.character
.length
!= e2
->value
.character
.length
)
261 return (args1
|| args2
) ? -2 : 0;
267 /* Helper function to look through parens, unary plus and widening
268 integer conversions. */
271 gfc_discard_nops (gfc_expr
*e
)
273 gfc_actual_arglist
*arglist
;
280 if (e
->expr_type
== EXPR_OP
281 && (e
->value
.op
.op
== INTRINSIC_UPLUS
282 || e
->value
.op
.op
== INTRINSIC_PARENTHESES
))
288 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
289 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
290 && e
->ts
.type
== BT_INTEGER
)
292 arglist
= e
->value
.function
.actual
;
293 if (arglist
->expr
->ts
.type
== BT_INTEGER
294 && e
->ts
.kind
> arglist
->expr
->ts
.kind
)
307 /* Compare two expressions. Return values:
311 * -2 if the relationship could not be determined
312 * -3 if e1 /= e2, but we cannot tell which one is larger.
313 REAL and COMPLEX constants are only compared for equality
314 or inequality; if they are unequal, -2 is returned in all cases. */
317 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
321 if (e1
== NULL
&& e2
== NULL
)
323 else if (e1
== NULL
|| e2
== NULL
)
326 e1
= gfc_discard_nops (e1
);
327 e2
= gfc_discard_nops (e2
);
329 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
331 /* Compare X+C vs. X, for INTEGER only. */
332 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
333 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
334 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
335 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
337 /* Compare P+Q vs. R+S. */
338 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
342 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
343 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
344 if (l
== 0 && r
== 0)
346 if (l
== 0 && r
> -2)
348 if (l
> -2 && r
== 0)
350 if (l
== 1 && r
== 1)
352 if (l
== -1 && r
== -1)
355 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
356 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
357 if (l
== 0 && r
== 0)
359 if (l
== 0 && r
> -2)
361 if (l
> -2 && r
== 0)
363 if (l
== 1 && r
== 1)
365 if (l
== -1 && r
== -1)
370 /* Compare X vs. X+C, for INTEGER only. */
371 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
373 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
374 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
375 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
376 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
379 /* Compare X-C vs. X, for INTEGER only. */
380 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
382 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
383 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
384 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
385 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
387 /* Compare P-Q vs. R-S. */
388 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
392 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
393 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
394 if (l
== 0 && r
== 0)
396 if (l
> -2 && r
== 0)
398 if (l
== 0 && r
> -2)
400 if (l
== 1 && r
== -1)
402 if (l
== -1 && r
== 1)
407 /* Compare A // B vs. C // D. */
409 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_CONCAT
410 && e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_CONCAT
)
414 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
415 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
420 /* Left expressions of // compare equal, but
421 watch out for 'A ' // x vs. 'A' // x. */
422 gfc_expr
*e1_left
= e1
->value
.op
.op1
;
423 gfc_expr
*e2_left
= e2
->value
.op
.op1
;
425 if (e1_left
->expr_type
== EXPR_CONSTANT
426 && e2_left
->expr_type
== EXPR_CONSTANT
427 && e1_left
->value
.character
.length
428 != e2_left
->value
.character
.length
)
434 /* Compare X vs. X-C, for INTEGER only. */
435 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
437 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
438 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
439 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
440 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
443 if (e1
->expr_type
!= e2
->expr_type
)
446 switch (e1
->expr_type
)
449 /* Compare strings for equality. */
450 if (e1
->ts
.type
== BT_CHARACTER
&& e2
->ts
.type
== BT_CHARACTER
)
451 return gfc_compare_string (e1
, e2
);
453 /* Compare REAL and COMPLEX constants. Because of the
454 traps and pitfalls associated with comparing
455 a + 1.0 with a + 0.5, check for equality only. */
456 if (e2
->expr_type
== EXPR_CONSTANT
)
458 if (e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
)
460 if (mpfr_cmp (e1
->value
.real
, e2
->value
.real
) == 0)
465 else if (e1
->ts
.type
== BT_COMPLEX
&& e2
->ts
.type
== BT_COMPLEX
)
467 if (mpc_cmp (e1
->value
.complex, e2
->value
.complex) == 0)
474 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
477 /* For INTEGER, all cases where e2 is not constant should have
478 been filtered out above. */
479 gcc_assert (e2
->expr_type
== EXPR_CONSTANT
);
481 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
489 if (are_identical_variables (e1
, e2
))
495 /* Intrinsic operators are the same if their operands are the same. */
496 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
498 if (e1
->value
.op
.op2
== 0)
500 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
501 return i
== 0 ? 0 : -2;
503 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
504 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
506 else if (e1
->value
.op
.op
== INTRINSIC_TIMES
507 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
) == 0
508 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
) == 0)
509 /* Commutativity of multiplication; addition is handled above. */
515 return gfc_dep_compare_functions (e1
, e2
, false);
523 /* Return the difference between two expressions. Integer expressions of
526 X + constant, X - constant and constant + X
528 are handled. Return true on success, false on failure. result is assumed
529 to be uninitialized on entry, and will be initialized on success.
533 gfc_dep_difference (gfc_expr
*e1
, gfc_expr
*e2
, mpz_t
*result
)
535 gfc_expr
*e1_op1
, *e1_op2
, *e2_op1
, *e2_op2
;
537 if (e1
== NULL
|| e2
== NULL
)
540 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
543 e1
= gfc_discard_nops (e1
);
544 e2
= gfc_discard_nops (e2
);
546 /* Initialize tentatively, clear if we don't return anything. */
549 /* Case 1: c1 - c2 = c1 - c2, trivially. */
551 if (e1
->expr_type
== EXPR_CONSTANT
&& e2
->expr_type
== EXPR_CONSTANT
)
553 mpz_sub (*result
, e1
->value
.integer
, e2
->value
.integer
);
557 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
559 e1_op1
= gfc_discard_nops (e1
->value
.op
.op1
);
560 e1_op2
= gfc_discard_nops (e1
->value
.op
.op2
);
562 /* Case 2: (X + c1) - X = c1. */
563 if (e1_op2
->expr_type
== EXPR_CONSTANT
564 && gfc_dep_compare_expr (e1_op1
, e2
) == 0)
566 mpz_set (*result
, e1_op2
->value
.integer
);
570 /* Case 3: (c1 + X) - X = c1. */
571 if (e1_op1
->expr_type
== EXPR_CONSTANT
572 && gfc_dep_compare_expr (e1_op2
, e2
) == 0)
574 mpz_set (*result
, e1_op1
->value
.integer
);
578 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
580 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
581 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
583 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
585 /* Case 4: X + c1 - (X + c2) = c1 - c2. */
586 if (e2_op2
->expr_type
== EXPR_CONSTANT
587 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
589 mpz_sub (*result
, e1_op2
->value
.integer
,
590 e2_op2
->value
.integer
);
593 /* Case 5: X + c1 - (c2 + X) = c1 - c2. */
594 if (e2_op1
->expr_type
== EXPR_CONSTANT
595 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
597 mpz_sub (*result
, e1_op2
->value
.integer
,
598 e2_op1
->value
.integer
);
602 else if (e1_op1
->expr_type
== EXPR_CONSTANT
)
604 /* Case 6: c1 + X - (X + c2) = c1 - c2. */
605 if (e2_op2
->expr_type
== EXPR_CONSTANT
606 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
608 mpz_sub (*result
, e1_op1
->value
.integer
,
609 e2_op2
->value
.integer
);
612 /* Case 7: c1 + X - (c2 + X) = c1 - c2. */
613 if (e2_op1
->expr_type
== EXPR_CONSTANT
614 && gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
616 mpz_sub (*result
, e1_op1
->value
.integer
,
617 e2_op1
->value
.integer
);
623 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
625 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
626 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
628 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
630 /* Case 8: X + c1 - (X - c2) = c1 + c2. */
631 if (e2_op2
->expr_type
== EXPR_CONSTANT
632 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
634 mpz_add (*result
, e1_op2
->value
.integer
,
635 e2_op2
->value
.integer
);
639 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
641 /* Case 9: c1 + X - (X - c2) = c1 + c2. */
642 if (e2_op2
->expr_type
== EXPR_CONSTANT
643 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
645 mpz_add (*result
, e1_op1
->value
.integer
,
646 e2_op2
->value
.integer
);
653 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
655 e1_op1
= gfc_discard_nops (e1
->value
.op
.op1
);
656 e1_op2
= gfc_discard_nops (e1
->value
.op
.op2
);
658 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
660 /* Case 10: (X - c1) - X = -c1 */
662 if (gfc_dep_compare_expr (e1_op1
, e2
) == 0)
664 mpz_neg (*result
, e1_op2
->value
.integer
);
668 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
670 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
671 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
673 /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
674 if (e2_op2
->expr_type
== EXPR_CONSTANT
675 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
677 mpz_add (*result
, e1_op2
->value
.integer
,
678 e2_op2
->value
.integer
);
679 mpz_neg (*result
, *result
);
683 /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
684 if (e2_op1
->expr_type
== EXPR_CONSTANT
685 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
687 mpz_add (*result
, e1_op2
->value
.integer
,
688 e2_op1
->value
.integer
);
689 mpz_neg (*result
, *result
);
694 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
696 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
697 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
699 /* Case 13: (X - c1) - (X - c2) = c2 - c1. */
700 if (e2_op2
->expr_type
== EXPR_CONSTANT
701 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
703 mpz_sub (*result
, e2_op2
->value
.integer
,
704 e1_op2
->value
.integer
);
709 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
711 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
713 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
714 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
716 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
717 if (gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
719 mpz_sub (*result
, e1_op1
->value
.integer
,
720 e2_op1
->value
.integer
);
728 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
730 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
731 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
733 /* Case 15: X - (X + c2) = -c2. */
734 if (e2_op2
->expr_type
== EXPR_CONSTANT
735 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
737 mpz_neg (*result
, e2_op2
->value
.integer
);
740 /* Case 16: X - (c2 + X) = -c2. */
741 if (e2_op1
->expr_type
== EXPR_CONSTANT
742 && gfc_dep_compare_expr (e1
, e2_op2
) == 0)
744 mpz_neg (*result
, e2_op1
->value
.integer
);
749 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
751 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
752 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
754 /* Case 17: X - (X - c2) = c2. */
755 if (e2_op2
->expr_type
== EXPR_CONSTANT
756 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
758 mpz_set (*result
, e2_op2
->value
.integer
);
763 if (gfc_dep_compare_expr (e1
, e2
) == 0)
765 /* Case 18: X - X = 0. */
766 mpz_set_si (*result
, 0);
774 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
775 results are indeterminate). 'n' is the dimension to compare. */
778 is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
)
784 /* TODO: More sophisticated range comparison. */
785 gcc_assert (ar1
&& ar2
);
787 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
791 /* Check for mismatching strides. A NULL stride means a stride of 1. */
794 i
= gfc_expr_is_one (e1
, -1);
795 if (i
== -1 || i
== 0)
800 i
= gfc_expr_is_one (e2
, -1);
801 if (i
== -1 || i
== 0)
806 i
= gfc_dep_compare_expr (e1
, e2
);
810 /* The strides match. */
812 /* Check the range start. */
817 /* Use the bound of the array if no bound is specified. */
819 e1
= ar1
->as
->lower
[n
];
822 e2
= ar2
->as
->lower
[n
];
824 /* Check we have values for both. */
828 i
= gfc_dep_compare_expr (e1
, e2
);
833 /* Check the range end. */
838 /* Use the bound of the array if no bound is specified. */
840 e1
= ar1
->as
->upper
[n
];
843 e2
= ar2
->as
->upper
[n
];
845 /* Check we have values for both. */
849 i
= gfc_dep_compare_expr (e1
, e2
);
858 /* Some array-returning intrinsics can be implemented by reusing the
859 data from one of the array arguments. For example, TRANSPOSE does
860 not necessarily need to allocate new data: it can be implemented
861 by copying the original array's descriptor and simply swapping the
862 two dimension specifications.
864 If EXPR is a call to such an intrinsic, return the argument
865 whose data can be reused, otherwise return NULL. */
868 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
870 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
873 switch (expr
->value
.function
.isym
->id
)
875 case GFC_ISYM_TRANSPOSE
:
876 return expr
->value
.function
.actual
->expr
;
884 /* Return true if the result of reference REF can only be constructed
885 using a temporary array. */
888 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
894 for (; ref
; ref
= ref
->next
)
898 /* Vector dimensions are generally not monotonic and must be
899 handled using a temporary. */
900 if (ref
->u
.ar
.type
== AR_SECTION
)
901 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
902 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
909 /* Within an array reference, character substrings generally
910 need a temporary. Character array strides are expressed as
911 multiples of the element size (consistent with other array
912 types), not in characters. */
925 gfc_is_data_pointer (gfc_expr
*e
)
929 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
932 /* No subreference if it is a function */
933 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
935 if (e
->symtree
->n
.sym
->attr
.pointer
)
938 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
939 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
946 /* Return true if array variable VAR could be passed to the same function
947 as argument EXPR without interfering with EXPR. INTENT is the intent
950 This is considerably less conservative than other dependencies
951 because many function arguments will already be copied into a
955 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
956 gfc_expr
*expr
, gfc_dep_check elemental
)
960 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
961 gcc_assert (var
->rank
> 0);
963 switch (expr
->expr_type
)
966 /* In case of elemental subroutines, there is no dependency
967 between two same-range array references. */
968 if (gfc_ref_needs_temporary_p (expr
->ref
)
969 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
971 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
973 /* Too many false positive with pointers. */
974 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
976 /* Elemental procedures forbid unspecified intents,
977 and we don't check dependencies for INTENT_IN args. */
978 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
980 /* We are told not to check dependencies.
981 We do it, however, and issue a warning in case we find one.
982 If a dependency is found in the case
983 elemental == ELEM_CHECK_VARIABLE, we will generate
984 a temporary, so we don't need to bother the user. */
986 if (var
->expr_type
== EXPR_VARIABLE
987 && expr
->expr_type
== EXPR_VARIABLE
988 && strcmp(var
->symtree
->name
, expr
->symtree
->name
) == 0)
989 gfc_warning (0, "INTENT(%s) actual argument at %L might "
990 "interfere with actual argument at %L.",
991 intent
== INTENT_OUT
? "OUT" : "INOUT",
992 &var
->where
, &expr
->where
);
1002 /* the scalarizer always generates a temporary for array constructors,
1003 so there is no dependency. */
1007 if (intent
!= INTENT_IN
)
1009 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
1011 return gfc_check_argument_var_dependency (var
, intent
, arg
,
1015 if (elemental
!= NOT_ELEMENTAL
)
1017 if ((expr
->value
.function
.esym
1018 && expr
->value
.function
.esym
->attr
.elemental
)
1019 || (expr
->value
.function
.isym
1020 && expr
->value
.function
.isym
->elemental
))
1021 return gfc_check_fncall_dependency (var
, intent
, NULL
,
1022 expr
->value
.function
.actual
,
1023 ELEM_CHECK_VARIABLE
);
1025 if (gfc_inline_intrinsic_function_p (expr
))
1027 /* The TRANSPOSE case should have been caught in the
1028 noncopying intrinsic case above. */
1029 gcc_assert (expr
->value
.function
.isym
->id
!= GFC_ISYM_TRANSPOSE
);
1031 return gfc_check_fncall_dependency (var
, intent
, NULL
,
1032 expr
->value
.function
.actual
,
1033 ELEM_CHECK_VARIABLE
);
1039 /* In case of non-elemental procedures, there is no need to catch
1040 dependencies, as we will make a temporary anyway. */
1043 /* If the actual arg EXPR is an expression, we need to catch
1044 a dependency between variables in EXPR and VAR,
1045 an intent((IN)OUT) variable. */
1046 if (expr
->value
.op
.op1
1047 && gfc_check_argument_var_dependency (var
, intent
,
1049 ELEM_CHECK_VARIABLE
))
1051 else if (expr
->value
.op
.op2
1052 && gfc_check_argument_var_dependency (var
, intent
,
1054 ELEM_CHECK_VARIABLE
))
1065 /* Like gfc_check_argument_var_dependency, but extended to any
1066 array expression OTHER, not just variables. */
1069 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
1070 gfc_expr
*expr
, gfc_dep_check elemental
)
1072 switch (other
->expr_type
)
1075 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
1078 other
= gfc_get_noncopying_intrinsic_argument (other
);
1080 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
1091 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
1092 FNSYM is the function being called, or NULL if not known. */
1095 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
1096 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
1097 gfc_dep_check elemental
)
1099 gfc_formal_arglist
*formal
;
1102 formal
= fnsym
? gfc_sym_get_dummy_args (fnsym
) : NULL
;
1103 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
1105 expr
= actual
->expr
;
1107 /* Skip args which are not present. */
1111 /* Skip other itself. */
1115 /* Skip intent(in) arguments if OTHER itself is intent(in). */
1116 if (formal
&& intent
== INTENT_IN
1117 && formal
->sym
->attr
.intent
== INTENT_IN
)
1120 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
1128 /* Return 1 if e1 and e2 are equivalenced arrays, either
1129 directly or indirectly; i.e., equivalence (a,b) for a and b
1130 or equivalence (a,c),(b,c). This function uses the equiv_
1131 lists, generated in trans-common(add_equivalences), that are
1132 guaranteed to pick up indirect equivalences. We explicitly
1133 check for overlap using the offset and length of the equivalence.
1134 This function is symmetric.
1135 TODO: This function only checks whether the full top-level
1136 symbols overlap. An improved implementation could inspect
1137 e1->ref and e2->ref to determine whether the actually accessed
1138 portions of these variables/arrays potentially overlap. */
1141 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
1144 gfc_equiv_info
*s
, *fl1
, *fl2
;
1146 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
1147 && e2
->expr_type
== EXPR_VARIABLE
);
1149 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
1150 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
1153 if (e1
->symtree
->n
.sym
->ns
1154 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
1155 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
1157 l
= gfc_current_ns
->equiv_lists
;
1159 /* Go through the equiv_lists and return 1 if the variables
1160 e1 and e2 are members of the same group and satisfy the
1161 requirement on their relative offsets. */
1162 for (; l
; l
= l
->next
)
1166 for (s
= l
->equiv
; s
; s
= s
->next
)
1168 if (s
->sym
== e1
->symtree
->n
.sym
)
1174 if (s
->sym
== e2
->symtree
->n
.sym
)
1184 /* Can these lengths be zero? */
1185 if (fl1
->length
<= 0 || fl2
->length
<= 0)
1187 /* These can't overlap if [f11,fl1+length] is before
1188 [fl2,fl2+length], or [fl2,fl2+length] is before
1189 [fl1,fl1+length], otherwise they do overlap. */
1190 if (fl1
->offset
+ fl1
->length
> fl2
->offset
1191 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
1199 /* Return true if there is no possibility of aliasing because of a type
1200 mismatch between all the possible pointer references and the
1201 potential target. Note that this function is asymmetric in the
1202 arguments and so must be called twice with the arguments exchanged. */
1205 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
1211 bool seen_component_ref
;
1213 if (expr1
->expr_type
!= EXPR_VARIABLE
1214 || expr2
->expr_type
!= EXPR_VARIABLE
)
1217 sym1
= expr1
->symtree
->n
.sym
;
1218 sym2
= expr2
->symtree
->n
.sym
;
1220 /* Keep it simple for now. */
1221 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
1224 if (sym1
->attr
.pointer
)
1226 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
1230 /* This is a conservative check on the components of the derived type
1231 if no component references have been seen. Since we will not dig
1232 into the components of derived type components, we play it safe by
1233 returning false. First we check the reference chain and then, if
1234 no component references have been seen, the components. */
1235 seen_component_ref
= false;
1236 if (sym1
->ts
.type
== BT_DERIVED
)
1238 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
1240 if (ref1
->type
!= REF_COMPONENT
)
1243 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
1246 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
1247 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
1250 seen_component_ref
= true;
1254 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
1256 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
1258 if (cm1
->ts
.type
== BT_DERIVED
)
1261 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
1262 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
1271 /* Return true if the statement body redefines the condition. Returns
1272 true if expr2 depends on expr1. expr1 should be a single term
1273 suitable for the lhs of an assignment. The IDENTICAL flag indicates
1274 whether array references to the same symbol with identical range
1275 references count as a dependency or not. Used for forall and where
1276 statements. Also used with functions returning arrays without a
1280 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
1282 gfc_actual_arglist
*actual
;
1286 /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
1287 and a reference to _F.caf_get, so skip the assert. */
1288 if (expr1
->expr_type
== EXPR_FUNCTION
1289 && strcmp (expr1
->value
.function
.name
, "_F.caf_get") == 0)
1292 if (expr1
->expr_type
!= EXPR_VARIABLE
)
1293 gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1295 /* Prevent NULL pointer dereference while recursively analyzing invalid
1300 switch (expr2
->expr_type
)
1303 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
1306 if (expr2
->value
.op
.op2
)
1307 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
1311 /* The interesting cases are when the symbols don't match. */
1312 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
1314 symbol_attribute attr1
, attr2
;
1315 gfc_typespec
*ts1
= &expr1
->symtree
->n
.sym
->ts
;
1316 gfc_typespec
*ts2
= &expr2
->symtree
->n
.sym
->ts
;
1318 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1319 if (gfc_are_equivalenced_arrays (expr1
, expr2
))
1322 /* Symbols can only alias if they have the same type. */
1323 if (ts1
->type
!= BT_UNKNOWN
&& ts2
->type
!= BT_UNKNOWN
1324 && ts1
->type
!= BT_DERIVED
&& ts2
->type
!= BT_DERIVED
)
1326 if (ts1
->type
!= ts2
->type
|| ts1
->kind
!= ts2
->kind
)
1330 /* We have to also include target-target as ptr%comp is not a
1331 pointer but it still alias with "dt%comp" for "ptr => dt". As
1332 subcomponents and array access to pointers retains the target
1333 attribute, that's sufficient. */
1334 attr1
= gfc_expr_attr (expr1
);
1335 attr2
= gfc_expr_attr (expr2
);
1336 if ((attr1
.pointer
|| attr1
.target
) && (attr2
.pointer
|| attr2
.target
))
1338 if (check_data_pointer_types (expr1
, expr2
)
1339 && check_data_pointer_types (expr2
, expr1
))
1346 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
1347 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
1348 if (sym1
->attr
.target
&& sym2
->attr
.target
1349 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
1350 && (!sym1
->attr
.dimension
1351 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
1352 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
1353 && (!sym2
->attr
.dimension
1354 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
1358 /* Otherwise distinct symbols have no dependencies. */
1362 /* Identical and disjoint ranges return 0,
1363 overlapping ranges return 1. */
1364 if (expr1
->ref
&& expr2
->ref
)
1365 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
, identical
);
1370 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
1373 /* Remember possible differences between elemental and
1374 transformational functions. All functions inside a FORALL
1376 for (actual
= expr2
->value
.function
.actual
;
1377 actual
; actual
= actual
->next
)
1381 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
1392 /* Loop through the array constructor's elements. */
1393 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
1394 c
; c
= gfc_constructor_next (c
))
1396 /* If this is an iterator, assume the worst. */
1399 /* Avoid recursion in the common case. */
1400 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1402 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1413 /* Determines overlapping for two array sections. */
1415 static gfc_dependency
1416 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1432 int stride_comparison
;
1433 int start_comparison
;
1436 /* If they are the same range, return without more ado. */
1437 if (is_same_range (l_ar
, r_ar
, n
))
1438 return GFC_DEP_EQUAL
;
1440 l_start
= l_ar
->start
[n
];
1441 l_end
= l_ar
->end
[n
];
1442 l_stride
= l_ar
->stride
[n
];
1444 r_start
= r_ar
->start
[n
];
1445 r_end
= r_ar
->end
[n
];
1446 r_stride
= r_ar
->stride
[n
];
1448 /* If l_start is NULL take it from array specifier. */
1449 if (l_start
== NULL
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1450 l_start
= l_ar
->as
->lower
[n
];
1451 /* If l_end is NULL take it from array specifier. */
1452 if (l_end
== NULL
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1453 l_end
= l_ar
->as
->upper
[n
];
1455 /* If r_start is NULL take it from array specifier. */
1456 if (r_start
== NULL
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1457 r_start
= r_ar
->as
->lower
[n
];
1458 /* If r_end is NULL take it from array specifier. */
1459 if (r_end
== NULL
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1460 r_end
= r_ar
->as
->upper
[n
];
1462 /* Determine whether the l_stride is positive or negative. */
1465 else if (l_stride
->expr_type
== EXPR_CONSTANT
1466 && l_stride
->ts
.type
== BT_INTEGER
)
1467 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1468 else if (l_start
&& l_end
)
1469 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1473 /* Determine whether the r_stride is positive or negative. */
1476 else if (r_stride
->expr_type
== EXPR_CONSTANT
1477 && r_stride
->ts
.type
== BT_INTEGER
)
1478 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1479 else if (r_start
&& r_end
)
1480 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1484 /* The strides should never be zero. */
1485 if (l_dir
== 0 || r_dir
== 0)
1486 return GFC_DEP_OVERLAP
;
1488 /* Determine the relationship between the strides. Set stride_comparison to
1489 -2 if the dependency cannot be determined
1490 -1 if l_stride < r_stride
1491 0 if l_stride == r_stride
1492 1 if l_stride > r_stride
1493 as determined by gfc_dep_compare_expr. */
1495 one_expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1497 stride_comparison
= gfc_dep_compare_expr (l_stride
? l_stride
: one_expr
,
1498 r_stride
? r_stride
: one_expr
);
1500 if (l_start
&& r_start
)
1501 start_comparison
= gfc_dep_compare_expr (l_start
, r_start
);
1503 start_comparison
= -2;
1505 gfc_free_expr (one_expr
);
1507 /* Determine LHS upper and lower bounds. */
1513 else if (l_dir
== -1)
1524 /* Determine RHS upper and lower bounds. */
1530 else if (r_dir
== -1)
1541 /* Check whether the ranges are disjoint. */
1542 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1543 return GFC_DEP_NODEP
;
1544 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1545 return GFC_DEP_NODEP
;
1547 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1548 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1550 if (l_dir
== 1 && r_dir
== -1)
1551 return GFC_DEP_EQUAL
;
1552 if (l_dir
== -1 && r_dir
== 1)
1553 return GFC_DEP_EQUAL
;
1556 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1557 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1559 if (l_dir
== 1 && r_dir
== -1)
1560 return GFC_DEP_EQUAL
;
1561 if (l_dir
== -1 && r_dir
== 1)
1562 return GFC_DEP_EQUAL
;
1565 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1566 There is no dependency if the remainder of
1567 (l_start - r_start) / gcd(l_stride, r_stride) is
1570 - Cases like a(1:4:2) = a(2:3) are still not handled.
1573 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1574 && (a)->ts.type == BT_INTEGER)
1576 if (IS_CONSTANT_INTEGER (l_stride
) && IS_CONSTANT_INTEGER (r_stride
)
1577 && gfc_dep_difference (l_start
, r_start
, &tmp
))
1583 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1585 mpz_fdiv_r (tmp
, tmp
, gcd
);
1586 result
= mpz_cmp_si (tmp
, 0L);
1592 return GFC_DEP_NODEP
;
1595 #undef IS_CONSTANT_INTEGER
1597 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1599 if (l_dir
== 1 && r_dir
== 1 &&
1600 (start_comparison
== 0 || start_comparison
== -1)
1601 && (stride_comparison
== 0 || stride_comparison
== -1))
1602 return GFC_DEP_FORWARD
;
1604 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1605 x:y:-1 vs. x:y:-2. */
1606 if (l_dir
== -1 && r_dir
== -1 &&
1607 (start_comparison
== 0 || start_comparison
== 1)
1608 && (stride_comparison
== 0 || stride_comparison
== 1))
1609 return GFC_DEP_FORWARD
;
1611 if (stride_comparison
== 0 || stride_comparison
== -1)
1613 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1616 /* Check for a(low:y:s) vs. a(z:x:s) or
1617 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1618 of low, which is always at least a forward dependence. */
1621 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1622 return GFC_DEP_FORWARD
;
1626 if (stride_comparison
== 0 || stride_comparison
== 1)
1628 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1631 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1632 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1633 of high, which is always at least a forward dependence. */
1636 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1637 return GFC_DEP_FORWARD
;
1642 if (stride_comparison
== 0)
1644 /* From here, check for backwards dependencies. */
1645 /* x+1:y vs. x:z. */
1646 if (l_dir
== 1 && r_dir
== 1 && start_comparison
== 1)
1647 return GFC_DEP_BACKWARD
;
1649 /* x-1:y:-1 vs. x:z:-1. */
1650 if (l_dir
== -1 && r_dir
== -1 && start_comparison
== -1)
1651 return GFC_DEP_BACKWARD
;
1654 return GFC_DEP_OVERLAP
;
1658 /* Determines overlapping for a single element and a section. */
1660 static gfc_dependency
1661 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1670 elem
= lref
->u
.ar
.start
[n
];
1672 return GFC_DEP_OVERLAP
;
1675 start
= ref
->start
[n
] ;
1677 stride
= ref
->stride
[n
];
1679 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1680 start
= ref
->as
->lower
[n
];
1681 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1682 end
= ref
->as
->upper
[n
];
1684 /* Determine whether the stride is positive or negative. */
1687 else if (stride
->expr_type
== EXPR_CONSTANT
1688 && stride
->ts
.type
== BT_INTEGER
)
1689 s
= mpz_sgn (stride
->value
.integer
);
1693 /* Stride should never be zero. */
1695 return GFC_DEP_OVERLAP
;
1697 /* Positive strides. */
1700 /* Check for elem < lower. */
1701 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1702 return GFC_DEP_NODEP
;
1703 /* Check for elem > upper. */
1704 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1705 return GFC_DEP_NODEP
;
1709 s
= gfc_dep_compare_expr (start
, end
);
1710 /* Check for an empty range. */
1712 return GFC_DEP_NODEP
;
1713 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1714 return GFC_DEP_EQUAL
;
1717 /* Negative strides. */
1720 /* Check for elem > upper. */
1721 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1722 return GFC_DEP_NODEP
;
1723 /* Check for elem < lower. */
1724 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1725 return GFC_DEP_NODEP
;
1729 s
= gfc_dep_compare_expr (start
, end
);
1730 /* Check for an empty range. */
1732 return GFC_DEP_NODEP
;
1733 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1734 return GFC_DEP_EQUAL
;
1737 /* Unknown strides. */
1741 return GFC_DEP_OVERLAP
;
1742 s
= gfc_dep_compare_expr (start
, end
);
1744 return GFC_DEP_OVERLAP
;
1745 /* Assume positive stride. */
1748 /* Check for elem < lower. */
1749 if (gfc_dep_compare_expr (elem
, start
) == -1)
1750 return GFC_DEP_NODEP
;
1751 /* Check for elem > upper. */
1752 if (gfc_dep_compare_expr (elem
, end
) == 1)
1753 return GFC_DEP_NODEP
;
1755 /* Assume negative stride. */
1758 /* Check for elem > upper. */
1759 if (gfc_dep_compare_expr (elem
, start
) == 1)
1760 return GFC_DEP_NODEP
;
1761 /* Check for elem < lower. */
1762 if (gfc_dep_compare_expr (elem
, end
) == -1)
1763 return GFC_DEP_NODEP
;
1768 s
= gfc_dep_compare_expr (elem
, start
);
1770 return GFC_DEP_EQUAL
;
1771 if (s
== 1 || s
== -1)
1772 return GFC_DEP_NODEP
;
1776 return GFC_DEP_OVERLAP
;
1780 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1781 forall_index attribute. Return true if any variable may be
1782 being used as a FORALL index. Its safe to pessimistically
1783 return true, and assume a dependency. */
1786 contains_forall_index_p (gfc_expr
*expr
)
1788 gfc_actual_arglist
*arg
;
1796 switch (expr
->expr_type
)
1799 if (expr
->symtree
->n
.sym
->forall_index
)
1804 if (contains_forall_index_p (expr
->value
.op
.op1
)
1805 || contains_forall_index_p (expr
->value
.op
.op2
))
1810 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1811 if (contains_forall_index_p (arg
->expr
))
1817 case EXPR_SUBSTRING
:
1820 case EXPR_STRUCTURE
:
1822 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1823 c
; gfc_constructor_next (c
))
1824 if (contains_forall_index_p (c
->expr
))
1832 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1836 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1837 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1838 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1839 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1847 if (contains_forall_index_p (ref
->u
.ss
.start
)
1848 || contains_forall_index_p (ref
->u
.ss
.end
))
1859 /* Determines overlapping for two single element array references. */
1861 static gfc_dependency
1862 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1872 l_start
= l_ar
.start
[n
] ;
1873 r_start
= r_ar
.start
[n
] ;
1874 i
= gfc_dep_compare_expr (r_start
, l_start
);
1876 return GFC_DEP_EQUAL
;
1878 /* Treat two scalar variables as potentially equal. This allows
1879 us to prove that a(i,:) and a(j,:) have no dependency. See
1880 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1881 Proceedings of the International Conference on Parallel and
1882 Distributed Processing Techniques and Applications (PDPTA2001),
1883 Las Vegas, Nevada, June 2001. */
1884 /* However, we need to be careful when either scalar expression
1885 contains a FORALL index, as these can potentially change value
1886 during the scalarization/traversal of this array reference. */
1887 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1888 return GFC_DEP_OVERLAP
;
1891 return GFC_DEP_NODEP
;
1893 return GFC_DEP_EQUAL
;
1896 /* Callback function for checking if an expression depends on a
1897 dummy variable which is any other than INTENT(IN). */
1900 callback_dummy_intent_not_in (gfc_expr
**ep
,
1901 int *walk_subtrees ATTRIBUTE_UNUSED
,
1902 void *data ATTRIBUTE_UNUSED
)
1906 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
1907 && e
->symtree
->n
.sym
->attr
.dummy
)
1908 return e
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
;
1913 /* Auxiliary function to check if subexpressions have dummy variables which
1918 dummy_intent_not_in (gfc_expr
**ep
)
1920 return gfc_expr_walker (ep
, callback_dummy_intent_not_in
, NULL
);
1923 /* Determine if an array ref, usually an array section specifies the
1924 entire array. In addition, if the second, pointer argument is
1925 provided, the function will return true if the reference is
1926 contiguous; eg. (:, 1) gives true but (1,:) gives false.
1927 If one of the bounds depends on a dummy variable which is
1928 not INTENT(IN), also return false, because the user may
1929 have changed the variable. */
1932 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1936 bool lbound_OK
= true;
1937 bool ubound_OK
= true;
1940 *contiguous
= false;
1942 if (ref
->type
!= REF_ARRAY
)
1945 if (ref
->u
.ar
.type
== AR_FULL
)
1952 if (ref
->u
.ar
.type
!= AR_SECTION
)
1957 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1959 /* If we have a single element in the reference, for the reference
1960 to be full, we need to ascertain that the array has a single
1961 element in this dimension and that we actually reference the
1963 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1965 /* This is unconditionally a contiguous reference if all the
1966 remaining dimensions are elements. */
1970 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1971 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1972 *contiguous
= false;
1976 || !ref
->u
.ar
.as
->lower
[i
]
1977 || !ref
->u
.ar
.as
->upper
[i
]
1978 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1979 ref
->u
.ar
.as
->upper
[i
])
1980 || !ref
->u
.ar
.start
[i
]
1981 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1982 ref
->u
.ar
.as
->lower
[i
]))
1988 /* Check the lower bound. */
1989 if (ref
->u
.ar
.start
[i
]
1991 || !ref
->u
.ar
.as
->lower
[i
]
1992 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1993 ref
->u
.ar
.as
->lower
[i
])
1994 || dummy_intent_not_in (&ref
->u
.ar
.start
[i
])))
1996 /* Check the upper bound. */
1997 if (ref
->u
.ar
.end
[i
]
1999 || !ref
->u
.ar
.as
->upper
[i
]
2000 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
2001 ref
->u
.ar
.as
->upper
[i
])
2002 || dummy_intent_not_in (&ref
->u
.ar
.end
[i
])))
2004 /* Check the stride. */
2005 if (ref
->u
.ar
.stride
[i
]
2006 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
2009 /* This is unconditionally a contiguous reference as long as all
2010 the subsequent dimensions are elements. */
2014 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
2015 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
2016 *contiguous
= false;
2019 if (!lbound_OK
|| !ubound_OK
)
2026 /* Determine if a full array is the same as an array section with one
2027 variable limit. For this to be so, the strides must both be unity
2028 and one of either start == lower or end == upper must be true. */
2031 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
2034 bool upper_or_lower
;
2036 if (full_ref
->type
!= REF_ARRAY
)
2038 if (full_ref
->u
.ar
.type
!= AR_FULL
)
2040 if (ref
->type
!= REF_ARRAY
)
2042 if (ref
->u
.ar
.type
== AR_FULL
)
2044 if (ref
->u
.ar
.type
!= AR_SECTION
)
2047 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2049 /* If we have a single element in the reference, we need to check
2050 that the array has a single element and that we actually reference
2051 the correct element. */
2052 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
2054 if (!full_ref
->u
.ar
.as
2055 || !full_ref
->u
.ar
.as
->lower
[i
]
2056 || !full_ref
->u
.ar
.as
->upper
[i
]
2057 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
2058 full_ref
->u
.ar
.as
->upper
[i
])
2059 || !ref
->u
.ar
.start
[i
]
2060 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
2061 full_ref
->u
.ar
.as
->lower
[i
]))
2065 /* Check the strides. */
2066 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
2068 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
2071 upper_or_lower
= false;
2072 /* Check the lower bound. */
2073 if (ref
->u
.ar
.start
[i
]
2075 && full_ref
->u
.ar
.as
->lower
[i
]
2076 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
2077 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
2078 upper_or_lower
= true;
2079 /* Check the upper bound. */
2080 if (ref
->u
.ar
.end
[i
]
2082 && full_ref
->u
.ar
.as
->upper
[i
]
2083 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
2084 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
2085 upper_or_lower
= true;
2086 if (!upper_or_lower
)
2093 /* Finds if two array references are overlapping or not.
2095 1 : array references are overlapping, or identical is true and
2096 there is some kind of overlap.
2097 0 : array references are identical or not overlapping. */
2100 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
,
2105 gfc_dependency fin_dep
;
2106 gfc_dependency this_dep
;
2107 bool same_component
= false;
2109 this_dep
= GFC_DEP_ERROR
;
2110 fin_dep
= GFC_DEP_ERROR
;
2111 /* Dependencies due to pointers should already have been identified.
2112 We only need to check for overlapping array references. */
2114 while (lref
&& rref
)
2116 /* The refs might come in mixed, one with a _data component and one
2117 without. Look at their next reference in order to avoid an
2120 if (lref
&& lref
->type
== REF_COMPONENT
&& lref
->u
.c
.component
2121 && strcmp (lref
->u
.c
.component
->name
, "_data") == 0)
2124 if (rref
&& rref
->type
== REF_COMPONENT
&& rref
->u
.c
.component
2125 && strcmp (rref
->u
.c
.component
->name
, "_data") == 0)
2128 /* We're resolving from the same base symbol, so both refs should be
2129 the same type. We traverse the reference chain until we find ranges
2130 that are not equal. */
2131 gcc_assert (lref
->type
== rref
->type
);
2135 /* The two ranges can't overlap if they are from different
2137 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
2140 same_component
= true;
2144 /* Substring overlaps are handled by the string assignment code
2145 if there is not an underlying dependency. */
2146 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
2149 /* Coarrays: If there is a coindex, either the image differs and there
2150 is no overlap or the image is the same - then the normal analysis
2151 applies. Hence, return early if either ref is coindexed and more
2152 than one image can exist. */
2153 if (flag_coarray
!= GFC_FCOARRAY_SINGLE
2154 && ((lref
->u
.ar
.codimen
2155 && lref
->u
.ar
.dimen_type
[lref
->u
.ar
.dimen
]
2156 != DIMEN_THIS_IMAGE
)
2157 || (rref
->u
.ar
.codimen
2158 && lref
->u
.ar
.dimen_type
[lref
->u
.ar
.dimen
]
2159 != DIMEN_THIS_IMAGE
)))
2161 if (lref
->u
.ar
.dimen
== 0 || rref
->u
.ar
.dimen
== 0)
2163 /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */
2164 if (lref
->u
.ar
.dimen
|| rref
->u
.ar
.dimen
)
2165 return 1; /* Just to be sure. */
2166 fin_dep
= GFC_DEP_EQUAL
;
2170 if (ref_same_as_full_array (lref
, rref
))
2173 if (ref_same_as_full_array (rref
, lref
))
2176 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
2178 if (lref
->u
.ar
.type
== AR_FULL
)
2179 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
2181 else if (rref
->u
.ar
.type
== AR_FULL
)
2182 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
2189 /* Index for the reverse array. */
2191 for (n
= 0; n
< lref
->u
.ar
.dimen
; n
++)
2193 /* Handle dependency when either of array reference is vector
2194 subscript. There is no dependency if the vector indices
2195 are equal or if indices are known to be different in a
2196 different dimension. */
2197 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2198 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2200 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2201 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2202 && gfc_dep_compare_expr (lref
->u
.ar
.start
[n
],
2203 rref
->u
.ar
.start
[n
]) == 0)
2204 this_dep
= GFC_DEP_EQUAL
;
2206 this_dep
= GFC_DEP_OVERLAP
;
2208 goto update_fin_dep
;
2211 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2212 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2213 this_dep
= check_section_vs_section (&lref
->u
.ar
,
2215 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2216 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2217 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
2218 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2219 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2220 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
2223 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2224 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
2225 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
2226 if (identical
&& this_dep
== GFC_DEP_EQUAL
)
2227 this_dep
= GFC_DEP_OVERLAP
;
2230 /* If any dimension doesn't overlap, we have no dependency. */
2231 if (this_dep
== GFC_DEP_NODEP
)
2234 /* Now deal with the loop reversal logic: This only works on
2235 ranges and is activated by setting
2236 reverse[n] == GFC_ENABLE_REVERSE
2237 The ability to reverse or not is set by previous conditions
2238 in this dimension. If reversal is not activated, the
2239 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2241 /* Get the indexing right for the scalarizing loop. If this
2242 is an element, there is no corresponding loop. */
2243 if (lref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
2246 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2247 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2251 /* Reverse if backward dependence and not inhibited. */
2252 if (reverse
[m
] == GFC_ENABLE_REVERSE
2253 && this_dep
== GFC_DEP_BACKWARD
)
2254 reverse
[m
] = GFC_REVERSE_SET
;
2256 /* Forward if forward dependence and not inhibited. */
2257 if (reverse
[m
] == GFC_ENABLE_REVERSE
2258 && this_dep
== GFC_DEP_FORWARD
)
2259 reverse
[m
] = GFC_FORWARD_SET
;
2261 /* Flag up overlap if dependence not compatible with
2262 the overall state of the expression. */
2263 if (reverse
[m
] == GFC_REVERSE_SET
2264 && this_dep
== GFC_DEP_FORWARD
)
2266 reverse
[m
] = GFC_INHIBIT_REVERSE
;
2267 this_dep
= GFC_DEP_OVERLAP
;
2269 else if (reverse
[m
] == GFC_FORWARD_SET
2270 && this_dep
== GFC_DEP_BACKWARD
)
2272 reverse
[m
] = GFC_INHIBIT_REVERSE
;
2273 this_dep
= GFC_DEP_OVERLAP
;
2277 /* If no intention of reversing or reversing is explicitly
2278 inhibited, convert backward dependence to overlap. */
2279 if ((!reverse
&& this_dep
== GFC_DEP_BACKWARD
)
2280 || (reverse
&& reverse
[m
] == GFC_INHIBIT_REVERSE
))
2281 this_dep
= GFC_DEP_OVERLAP
;
2284 /* Overlap codes are in order of priority. We only need to
2285 know the worst one.*/
2288 if (identical
&& this_dep
== GFC_DEP_EQUAL
)
2289 this_dep
= GFC_DEP_OVERLAP
;
2291 if (this_dep
> fin_dep
)
2295 /* If this is an equal element, we have to keep going until we find
2296 the "real" array reference. */
2297 if (lref
->u
.ar
.type
== AR_ELEMENT
2298 && rref
->u
.ar
.type
== AR_ELEMENT
2299 && fin_dep
== GFC_DEP_EQUAL
)
2302 /* Exactly matching and forward overlapping ranges don't cause a
2304 if (fin_dep
< GFC_DEP_BACKWARD
&& !identical
)
2307 /* Keep checking. We only have a dependency if
2308 subsequent references also overlap. */
2312 if (lref
->u
.i
!= rref
->u
.i
)
2324 /* Assume the worst if we nest to different depths. */
2328 /* This can result from concatenation of assumed length string components. */
2329 if (same_component
&& fin_dep
== GFC_DEP_ERROR
)
2332 /* If we haven't seen any array refs then something went wrong. */
2333 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
2335 if (identical
&& fin_dep
!= GFC_DEP_NODEP
)
2338 return fin_dep
== GFC_DEP_OVERLAP
;