2 Copyright (C) 2000-2015 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. */
50 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
52 /* Forward declarations */
54 static gfc_dependency
check_section_vs_section (gfc_array_ref
*,
55 gfc_array_ref
*, int);
57 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
58 def if the value could not be determined. */
61 gfc_expr_is_one (gfc_expr
*expr
, int def
)
63 gcc_assert (expr
!= NULL
);
65 if (expr
->expr_type
!= EXPR_CONSTANT
)
68 if (expr
->ts
.type
!= BT_INTEGER
)
71 return mpz_cmp_si (expr
->value
.integer
, 1) == 0;
74 /* Check if two array references are known to be identical. Calls
75 gfc_dep_compare_expr if necessary for comparing array indices. */
78 identical_array_ref (gfc_array_ref
*a1
, gfc_array_ref
*a2
)
82 if (a1
->type
== AR_FULL
&& a2
->type
== AR_FULL
)
85 if (a1
->type
== AR_SECTION
&& a2
->type
== AR_SECTION
)
87 gcc_assert (a1
->dimen
== a2
->dimen
);
89 for ( i
= 0; i
< a1
->dimen
; i
++)
91 /* TODO: Currently, we punt on an integer array as an index. */
92 if (a1
->dimen_type
[i
] != DIMEN_RANGE
93 || a2
->dimen_type
[i
] != DIMEN_RANGE
)
96 if (check_section_vs_section (a1
, a2
, i
) != GFC_DEP_EQUAL
)
102 if (a1
->type
== AR_ELEMENT
&& a2
->type
== AR_ELEMENT
)
104 gcc_assert (a1
->dimen
== a2
->dimen
);
105 for (i
= 0; i
< a1
->dimen
; i
++)
107 if (gfc_dep_compare_expr (a1
->start
[i
], a2
->start
[i
]) != 0)
117 /* Return true for identical variables, checking for references if
118 necessary. Calls identical_array_ref for checking array sections. */
121 are_identical_variables (gfc_expr
*e1
, gfc_expr
*e2
)
125 if (e1
->symtree
->n
.sym
->attr
.dummy
&& e2
->symtree
->n
.sym
->attr
.dummy
)
127 /* Dummy arguments: Only check for equal names. */
128 if (e1
->symtree
->n
.sym
->name
!= e2
->symtree
->n
.sym
->name
)
133 /* Check for equal symbols. */
134 if (e1
->symtree
->n
.sym
!= e2
->symtree
->n
.sym
)
138 /* Volatile variables should never compare equal to themselves. */
140 if (e1
->symtree
->n
.sym
->attr
.volatile_
)
146 while (r1
!= NULL
|| r2
!= NULL
)
149 /* Assume the variables are not equal if one has a reference and the
151 TODO: Handle full references like comparing a(:) to a.
154 if (r1
== NULL
|| r2
== NULL
)
157 if (r1
->type
!= r2
->type
)
164 if (!identical_array_ref (&r1
->u
.ar
, &r2
->u
.ar
))
170 if (r1
->u
.c
.component
!= r2
->u
.c
.component
)
175 if (gfc_dep_compare_expr (r1
->u
.ss
.start
, r2
->u
.ss
.start
) != 0)
178 /* If both are NULL, the end length compares equal, because we
179 are looking at the same variable. This can only happen for
180 assumed- or deferred-length character arguments. */
182 if (r1
->u
.ss
.end
== NULL
&& r2
->u
.ss
.end
== NULL
)
185 if (gfc_dep_compare_expr (r1
->u
.ss
.end
, r2
->u
.ss
.end
) != 0)
191 gfc_internal_error ("are_identical_variables: Bad type");
199 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If
200 impure_ok is false, only return 0 for pure functions. */
203 gfc_dep_compare_functions (gfc_expr
*e1
, gfc_expr
*e2
, bool impure_ok
)
206 gfc_actual_arglist
*args1
;
207 gfc_actual_arglist
*args2
;
209 if (e1
->expr_type
!= EXPR_FUNCTION
|| e2
->expr_type
!= EXPR_FUNCTION
)
212 if ((e1
->value
.function
.esym
&& e2
->value
.function
.esym
213 && e1
->value
.function
.esym
== e2
->value
.function
.esym
214 && (e1
->value
.function
.esym
->result
->attr
.pure
|| impure_ok
))
215 || (e1
->value
.function
.isym
&& e2
->value
.function
.isym
216 && e1
->value
.function
.isym
== e2
->value
.function
.isym
217 && (e1
->value
.function
.isym
->pure
|| impure_ok
)))
219 args1
= e1
->value
.function
.actual
;
220 args2
= e2
->value
.function
.actual
;
222 /* Compare the argument lists for equality. */
223 while (args1
&& args2
)
225 /* Bitwise xor, since C has no non-bitwise xor operator. */
226 if ((args1
->expr
== NULL
) ^ (args2
->expr
== NULL
))
229 if (args1
->expr
!= NULL
&& args2
->expr
!= NULL
230 && gfc_dep_compare_expr (args1
->expr
, args2
->expr
) != 0)
236 return (args1
|| args2
) ? -2 : 0;
242 /* Helper function to look through parens, unary plus and widening
243 integer conversions. */
246 gfc_discard_nops (gfc_expr
*e
)
248 gfc_actual_arglist
*arglist
;
255 if (e
->expr_type
== EXPR_OP
256 && (e
->value
.op
.op
== INTRINSIC_UPLUS
257 || e
->value
.op
.op
== INTRINSIC_PARENTHESES
))
263 if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.isym
264 && e
->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
265 && e
->ts
.type
== BT_INTEGER
)
267 arglist
= e
->value
.function
.actual
;
268 if (arglist
->expr
->ts
.type
== BT_INTEGER
269 && e
->ts
.kind
> arglist
->expr
->ts
.kind
)
282 /* Compare two expressions. Return values:
286 * -2 if the relationship could not be determined
287 * -3 if e1 /= e2, but we cannot tell which one is larger.
288 REAL and COMPLEX constants are only compared for equality
289 or inequality; if they are unequal, -2 is returned in all cases. */
292 gfc_dep_compare_expr (gfc_expr
*e1
, gfc_expr
*e2
)
296 if (e1
== NULL
&& e2
== NULL
)
299 e1
= gfc_discard_nops (e1
);
300 e2
= gfc_discard_nops (e2
);
302 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
304 /* Compare X+C vs. X, for INTEGER only. */
305 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
306 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
307 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
308 return mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
310 /* Compare P+Q vs. R+S. */
311 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
315 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
316 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
317 if (l
== 0 && r
== 0)
319 if (l
== 0 && r
> -2)
321 if (l
> -2 && r
== 0)
323 if (l
== 1 && r
== 1)
325 if (l
== -1 && r
== -1)
328 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
);
329 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
);
330 if (l
== 0 && r
== 0)
332 if (l
== 0 && r
> -2)
334 if (l
> -2 && r
== 0)
336 if (l
== 1 && r
== 1)
338 if (l
== -1 && r
== -1)
343 /* Compare X vs. X+C, for INTEGER only. */
344 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
346 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
347 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
348 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
349 return -mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
352 /* Compare X-C vs. X, for INTEGER only. */
353 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
355 if (e1
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
356 && e1
->value
.op
.op2
->ts
.type
== BT_INTEGER
357 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
) == 0)
358 return -mpz_sgn (e1
->value
.op
.op2
->value
.integer
);
360 /* Compare P-Q vs. R-S. */
361 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
365 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
366 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
367 if (l
== 0 && r
== 0)
369 if (l
> -2 && r
== 0)
371 if (l
== 0 && r
> -2)
373 if (l
== 1 && r
== -1)
375 if (l
== -1 && r
== 1)
380 /* Compare A // B vs. C // D. */
382 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_CONCAT
383 && e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_CONCAT
)
387 l
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
388 r
= gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
);
393 /* Left expressions of // compare equal, but
394 watch out for 'A ' // x vs. 'A' // x. */
395 gfc_expr
*e1_left
= e1
->value
.op
.op1
;
396 gfc_expr
*e2_left
= e2
->value
.op
.op1
;
398 if (e1_left
->expr_type
== EXPR_CONSTANT
399 && e2_left
->expr_type
== EXPR_CONSTANT
400 && e1_left
->value
.character
.length
401 != e2_left
->value
.character
.length
)
407 /* Compare X vs. X-C, for INTEGER only. */
408 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
410 if (e2
->value
.op
.op2
->expr_type
== EXPR_CONSTANT
411 && e2
->value
.op
.op2
->ts
.type
== BT_INTEGER
412 && gfc_dep_compare_expr (e1
, e2
->value
.op
.op1
) == 0)
413 return mpz_sgn (e2
->value
.op
.op2
->value
.integer
);
416 if (e1
->expr_type
!= e2
->expr_type
)
419 switch (e1
->expr_type
)
422 /* Compare strings for equality. */
423 if (e1
->ts
.type
== BT_CHARACTER
&& e2
->ts
.type
== BT_CHARACTER
)
424 return gfc_compare_string (e1
, e2
);
426 /* Compare REAL and COMPLEX constants. Because of the
427 traps and pitfalls associated with comparing
428 a + 1.0 with a + 0.5, check for equality only. */
429 if (e2
->expr_type
== EXPR_CONSTANT
)
431 if (e1
->ts
.type
== BT_REAL
&& e2
->ts
.type
== BT_REAL
)
433 if (mpfr_cmp (e1
->value
.real
, e2
->value
.real
) == 0)
438 else if (e1
->ts
.type
== BT_COMPLEX
&& e2
->ts
.type
== BT_COMPLEX
)
440 if (mpc_cmp (e1
->value
.complex, e2
->value
.complex) == 0)
447 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
450 /* For INTEGER, all cases where e2 is not constant should have
451 been filtered out above. */
452 gcc_assert (e2
->expr_type
== EXPR_CONSTANT
);
454 i
= mpz_cmp (e1
->value
.integer
, e2
->value
.integer
);
462 if (are_identical_variables (e1
, e2
))
468 /* Intrinsic operators are the same if their operands are the same. */
469 if (e1
->value
.op
.op
!= e2
->value
.op
.op
)
471 if (e1
->value
.op
.op2
== 0)
473 i
= gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
);
474 return i
== 0 ? 0 : -2;
476 if (gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op1
) == 0
477 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op2
) == 0)
479 else if (e1
->value
.op
.op
== INTRINSIC_TIMES
480 && gfc_dep_compare_expr (e1
->value
.op
.op1
, e2
->value
.op
.op2
) == 0
481 && gfc_dep_compare_expr (e1
->value
.op
.op2
, e2
->value
.op
.op1
) == 0)
482 /* Commutativity of multiplication; addition is handled above. */
488 return gfc_dep_compare_functions (e1
, e2
, false);
497 /* Return the difference between two expressions. Integer expressions of
500 X + constant, X - constant and constant + X
502 are handled. Return true on success, false on failure. result is assumed
503 to be uninitialized on entry, and will be initialized on success.
507 gfc_dep_difference (gfc_expr
*e1
, gfc_expr
*e2
, mpz_t
*result
)
509 gfc_expr
*e1_op1
, *e1_op2
, *e2_op1
, *e2_op2
;
511 if (e1
== NULL
|| e2
== NULL
)
514 if (e1
->ts
.type
!= BT_INTEGER
|| e2
->ts
.type
!= BT_INTEGER
)
517 e1
= gfc_discard_nops (e1
);
518 e2
= gfc_discard_nops (e2
);
520 /* Inizialize tentatively, clear if we don't return anything. */
523 /* Case 1: c1 - c2 = c1 - c2, trivially. */
525 if (e1
->expr_type
== EXPR_CONSTANT
&& e2
->expr_type
== EXPR_CONSTANT
)
527 mpz_sub (*result
, e1
->value
.integer
, e2
->value
.integer
);
531 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_PLUS
)
533 e1_op1
= gfc_discard_nops (e1
->value
.op
.op1
);
534 e1_op2
= gfc_discard_nops (e1
->value
.op
.op2
);
536 /* Case 2: (X + c1) - X = c1. */
537 if (e1_op2
->expr_type
== EXPR_CONSTANT
538 && gfc_dep_compare_expr (e1_op1
, e2
) == 0)
540 mpz_set (*result
, e1_op2
->value
.integer
);
544 /* Case 3: (c1 + X) - X = c1. */
545 if (e1_op1
->expr_type
== EXPR_CONSTANT
546 && gfc_dep_compare_expr (e1_op2
, e2
) == 0)
548 mpz_set (*result
, e1_op1
->value
.integer
);
552 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
554 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
555 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
557 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
559 /* Case 4: X + c1 - (X + c2) = c1 - c2. */
560 if (e2_op2
->expr_type
== EXPR_CONSTANT
561 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
563 mpz_sub (*result
, e1_op2
->value
.integer
,
564 e2_op2
->value
.integer
);
567 /* Case 5: X + c1 - (c2 + X) = c1 - c2. */
568 if (e2_op1
->expr_type
== EXPR_CONSTANT
569 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
571 mpz_sub (*result
, e1_op2
->value
.integer
,
572 e2_op1
->value
.integer
);
576 else if (e1_op1
->expr_type
== EXPR_CONSTANT
)
578 /* Case 6: c1 + X - (X + c2) = c1 - c2. */
579 if (e2_op2
->expr_type
== EXPR_CONSTANT
580 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
582 mpz_sub (*result
, e1_op1
->value
.integer
,
583 e2_op2
->value
.integer
);
586 /* Case 7: c1 + X - (c2 + X) = c1 - c2. */
587 if (e2_op1
->expr_type
== EXPR_CONSTANT
588 && gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
590 mpz_sub (*result
, e1_op1
->value
.integer
,
591 e2_op1
->value
.integer
);
597 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
599 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
600 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
602 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
604 /* Case 8: X + c1 - (X - c2) = c1 + c2. */
605 if (e2_op2
->expr_type
== EXPR_CONSTANT
606 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
608 mpz_add (*result
, e1_op2
->value
.integer
,
609 e2_op2
->value
.integer
);
613 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
615 /* Case 9: c1 + X - (X - c2) = c1 + c2. */
616 if (e2_op2
->expr_type
== EXPR_CONSTANT
617 && gfc_dep_compare_expr (e1_op2
, e2_op1
) == 0)
619 mpz_add (*result
, e1_op1
->value
.integer
,
620 e2_op2
->value
.integer
);
627 if (e1
->expr_type
== EXPR_OP
&& e1
->value
.op
.op
== INTRINSIC_MINUS
)
629 e1_op1
= gfc_discard_nops (e1
->value
.op
.op1
);
630 e1_op2
= gfc_discard_nops (e1
->value
.op
.op2
);
632 if (e1_op2
->expr_type
== EXPR_CONSTANT
)
634 /* Case 10: (X - c1) - X = -c1 */
636 if (gfc_dep_compare_expr (e1_op1
, e2
) == 0)
638 mpz_neg (*result
, e1_op2
->value
.integer
);
642 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
644 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
645 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
647 /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */
648 if (e2_op2
->expr_type
== EXPR_CONSTANT
649 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
651 mpz_add (*result
, e1_op2
->value
.integer
,
652 e2_op2
->value
.integer
);
653 mpz_neg (*result
, *result
);
657 /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */
658 if (e2_op1
->expr_type
== EXPR_CONSTANT
659 && gfc_dep_compare_expr (e1_op1
, e2_op2
) == 0)
661 mpz_add (*result
, e1_op2
->value
.integer
,
662 e2_op1
->value
.integer
);
663 mpz_neg (*result
, *result
);
668 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
670 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
671 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
673 /* Case 13: (X - c1) - (X - c2) = c2 - c1. */
674 if (e2_op2
->expr_type
== EXPR_CONSTANT
675 && gfc_dep_compare_expr (e1_op1
, e2_op1
) == 0)
677 mpz_sub (*result
, e2_op2
->value
.integer
,
678 e1_op2
->value
.integer
);
683 if (e1_op1
->expr_type
== EXPR_CONSTANT
)
685 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
687 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
688 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
690 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
691 if (gfc_dep_compare_expr (e1_op2
, e2_op2
) == 0)
693 mpz_sub (*result
, e1_op1
->value
.integer
,
694 e2_op1
->value
.integer
);
702 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_PLUS
)
704 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
705 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
707 /* Case 15: X - (X + c2) = -c2. */
708 if (e2_op2
->expr_type
== EXPR_CONSTANT
709 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
711 mpz_neg (*result
, e2_op2
->value
.integer
);
714 /* Case 16: X - (c2 + X) = -c2. */
715 if (e2_op1
->expr_type
== EXPR_CONSTANT
716 && gfc_dep_compare_expr (e1
, e2_op2
) == 0)
718 mpz_neg (*result
, e2_op1
->value
.integer
);
723 if (e2
->expr_type
== EXPR_OP
&& e2
->value
.op
.op
== INTRINSIC_MINUS
)
725 e2_op1
= gfc_discard_nops (e2
->value
.op
.op1
);
726 e2_op2
= gfc_discard_nops (e2
->value
.op
.op2
);
728 /* Case 17: X - (X - c2) = c2. */
729 if (e2_op2
->expr_type
== EXPR_CONSTANT
730 && gfc_dep_compare_expr (e1
, e2_op1
) == 0)
732 mpz_set (*result
, e2_op2
->value
.integer
);
737 if (gfc_dep_compare_expr (e1
, e2
) == 0)
739 /* Case 18: X - X = 0. */
740 mpz_set_si (*result
, 0);
748 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the
749 results are indeterminate). 'n' is the dimension to compare. */
752 is_same_range (gfc_array_ref
*ar1
, gfc_array_ref
*ar2
, int n
)
758 /* TODO: More sophisticated range comparison. */
759 gcc_assert (ar1
&& ar2
);
761 gcc_assert (ar1
->dimen_type
[n
] == ar2
->dimen_type
[n
]);
765 /* Check for mismatching strides. A NULL stride means a stride of 1. */
768 i
= gfc_expr_is_one (e1
, -1);
769 if (i
== -1 || i
== 0)
774 i
= gfc_expr_is_one (e2
, -1);
775 if (i
== -1 || i
== 0)
780 i
= gfc_dep_compare_expr (e1
, e2
);
784 /* The strides match. */
786 /* Check the range start. */
791 /* Use the bound of the array if no bound is specified. */
793 e1
= ar1
->as
->lower
[n
];
796 e2
= ar2
->as
->lower
[n
];
798 /* Check we have values for both. */
802 i
= gfc_dep_compare_expr (e1
, e2
);
807 /* Check the range end. */
812 /* Use the bound of the array if no bound is specified. */
814 e1
= ar1
->as
->upper
[n
];
817 e2
= ar2
->as
->upper
[n
];
819 /* Check we have values for both. */
823 i
= gfc_dep_compare_expr (e1
, e2
);
832 /* Some array-returning intrinsics can be implemented by reusing the
833 data from one of the array arguments. For example, TRANSPOSE does
834 not necessarily need to allocate new data: it can be implemented
835 by copying the original array's descriptor and simply swapping the
836 two dimension specifications.
838 If EXPR is a call to such an intrinsic, return the argument
839 whose data can be reused, otherwise return NULL. */
842 gfc_get_noncopying_intrinsic_argument (gfc_expr
*expr
)
844 if (expr
->expr_type
!= EXPR_FUNCTION
|| !expr
->value
.function
.isym
)
847 switch (expr
->value
.function
.isym
->id
)
849 case GFC_ISYM_TRANSPOSE
:
850 return expr
->value
.function
.actual
->expr
;
858 /* Return true if the result of reference REF can only be constructed
859 using a temporary array. */
862 gfc_ref_needs_temporary_p (gfc_ref
*ref
)
868 for (; ref
; ref
= ref
->next
)
872 /* Vector dimensions are generally not monotonic and must be
873 handled using a temporary. */
874 if (ref
->u
.ar
.type
== AR_SECTION
)
875 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
876 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
883 /* Within an array reference, character substrings generally
884 need a temporary. Character array strides are expressed as
885 multiples of the element size (consistent with other array
886 types), not in characters. */
898 gfc_is_data_pointer (gfc_expr
*e
)
902 if (e
->expr_type
!= EXPR_VARIABLE
&& e
->expr_type
!= EXPR_FUNCTION
)
905 /* No subreference if it is a function */
906 gcc_assert (e
->expr_type
== EXPR_VARIABLE
|| !e
->ref
);
908 if (e
->symtree
->n
.sym
->attr
.pointer
)
911 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
912 if (ref
->type
== REF_COMPONENT
&& ref
->u
.c
.component
->attr
.pointer
)
919 /* Return true if array variable VAR could be passed to the same function
920 as argument EXPR without interfering with EXPR. INTENT is the intent
923 This is considerably less conservative than other dependencies
924 because many function arguments will already be copied into a
928 gfc_check_argument_var_dependency (gfc_expr
*var
, sym_intent intent
,
929 gfc_expr
*expr
, gfc_dep_check elemental
)
933 gcc_assert (var
->expr_type
== EXPR_VARIABLE
);
934 gcc_assert (var
->rank
> 0);
936 switch (expr
->expr_type
)
939 /* In case of elemental subroutines, there is no dependency
940 between two same-range array references. */
941 if (gfc_ref_needs_temporary_p (expr
->ref
)
942 || gfc_check_dependency (var
, expr
, elemental
== NOT_ELEMENTAL
))
944 if (elemental
== ELEM_DONT_CHECK_VARIABLE
)
946 /* Too many false positive with pointers. */
947 if (!gfc_is_data_pointer (var
) && !gfc_is_data_pointer (expr
))
949 /* Elemental procedures forbid unspecified intents,
950 and we don't check dependencies for INTENT_IN args. */
951 gcc_assert (intent
== INTENT_OUT
|| intent
== INTENT_INOUT
);
953 /* We are told not to check dependencies.
954 We do it, however, and issue a warning in case we find one.
955 If a dependency is found in the case
956 elemental == ELEM_CHECK_VARIABLE, we will generate
957 a temporary, so we don't need to bother the user. */
958 gfc_warning (0, "INTENT(%s) actual argument at %L might "
959 "interfere with actual argument at %L.",
960 intent
== INTENT_OUT
? "OUT" : "INOUT",
961 &var
->where
, &expr
->where
);
971 /* the scalarizer always generates a temporary for array constructors,
972 so there is no dependency. */
976 if (intent
!= INTENT_IN
)
978 arg
= gfc_get_noncopying_intrinsic_argument (expr
);
980 return gfc_check_argument_var_dependency (var
, intent
, arg
,
984 if (elemental
!= NOT_ELEMENTAL
)
986 if ((expr
->value
.function
.esym
987 && expr
->value
.function
.esym
->attr
.elemental
)
988 || (expr
->value
.function
.isym
989 && expr
->value
.function
.isym
->elemental
))
990 return gfc_check_fncall_dependency (var
, intent
, NULL
,
991 expr
->value
.function
.actual
,
992 ELEM_CHECK_VARIABLE
);
994 if (gfc_inline_intrinsic_function_p (expr
))
996 /* The TRANSPOSE case should have been caught in the
997 noncopying intrinsic case above. */
998 gcc_assert (expr
->value
.function
.isym
->id
!= GFC_ISYM_TRANSPOSE
);
1000 return gfc_check_fncall_dependency (var
, intent
, NULL
,
1001 expr
->value
.function
.actual
,
1002 ELEM_CHECK_VARIABLE
);
1008 /* In case of non-elemental procedures, there is no need to catch
1009 dependencies, as we will make a temporary anyway. */
1012 /* If the actual arg EXPR is an expression, we need to catch
1013 a dependency between variables in EXPR and VAR,
1014 an intent((IN)OUT) variable. */
1015 if (expr
->value
.op
.op1
1016 && gfc_check_argument_var_dependency (var
, intent
,
1018 ELEM_CHECK_VARIABLE
))
1020 else if (expr
->value
.op
.op2
1021 && gfc_check_argument_var_dependency (var
, intent
,
1023 ELEM_CHECK_VARIABLE
))
1034 /* Like gfc_check_argument_var_dependency, but extended to any
1035 array expression OTHER, not just variables. */
1038 gfc_check_argument_dependency (gfc_expr
*other
, sym_intent intent
,
1039 gfc_expr
*expr
, gfc_dep_check elemental
)
1041 switch (other
->expr_type
)
1044 return gfc_check_argument_var_dependency (other
, intent
, expr
, elemental
);
1047 other
= gfc_get_noncopying_intrinsic_argument (other
);
1049 return gfc_check_argument_dependency (other
, INTENT_IN
, expr
,
1060 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
1061 FNSYM is the function being called, or NULL if not known. */
1064 gfc_check_fncall_dependency (gfc_expr
*other
, sym_intent intent
,
1065 gfc_symbol
*fnsym
, gfc_actual_arglist
*actual
,
1066 gfc_dep_check elemental
)
1068 gfc_formal_arglist
*formal
;
1071 formal
= fnsym
? gfc_sym_get_dummy_args (fnsym
) : NULL
;
1072 for (; actual
; actual
= actual
->next
, formal
= formal
? formal
->next
: NULL
)
1074 expr
= actual
->expr
;
1076 /* Skip args which are not present. */
1080 /* Skip other itself. */
1084 /* Skip intent(in) arguments if OTHER itself is intent(in). */
1085 if (formal
&& intent
== INTENT_IN
1086 && formal
->sym
->attr
.intent
== INTENT_IN
)
1089 if (gfc_check_argument_dependency (other
, intent
, expr
, elemental
))
1097 /* Return 1 if e1 and e2 are equivalenced arrays, either
1098 directly or indirectly; i.e., equivalence (a,b) for a and b
1099 or equivalence (a,c),(b,c). This function uses the equiv_
1100 lists, generated in trans-common(add_equivalences), that are
1101 guaranteed to pick up indirect equivalences. We explicitly
1102 check for overlap using the offset and length of the equivalence.
1103 This function is symmetric.
1104 TODO: This function only checks whether the full top-level
1105 symbols overlap. An improved implementation could inspect
1106 e1->ref and e2->ref to determine whether the actually accessed
1107 portions of these variables/arrays potentially overlap. */
1110 gfc_are_equivalenced_arrays (gfc_expr
*e1
, gfc_expr
*e2
)
1113 gfc_equiv_info
*s
, *fl1
, *fl2
;
1115 gcc_assert (e1
->expr_type
== EXPR_VARIABLE
1116 && e2
->expr_type
== EXPR_VARIABLE
);
1118 if (!e1
->symtree
->n
.sym
->attr
.in_equivalence
1119 || !e2
->symtree
->n
.sym
->attr
.in_equivalence
|| !e1
->rank
|| !e2
->rank
)
1122 if (e1
->symtree
->n
.sym
->ns
1123 && e1
->symtree
->n
.sym
->ns
!= gfc_current_ns
)
1124 l
= e1
->symtree
->n
.sym
->ns
->equiv_lists
;
1126 l
= gfc_current_ns
->equiv_lists
;
1128 /* Go through the equiv_lists and return 1 if the variables
1129 e1 and e2 are members of the same group and satisfy the
1130 requirement on their relative offsets. */
1131 for (; l
; l
= l
->next
)
1135 for (s
= l
->equiv
; s
; s
= s
->next
)
1137 if (s
->sym
== e1
->symtree
->n
.sym
)
1143 if (s
->sym
== e2
->symtree
->n
.sym
)
1153 /* Can these lengths be zero? */
1154 if (fl1
->length
<= 0 || fl2
->length
<= 0)
1156 /* These can't overlap if [f11,fl1+length] is before
1157 [fl2,fl2+length], or [fl2,fl2+length] is before
1158 [fl1,fl1+length], otherwise they do overlap. */
1159 if (fl1
->offset
+ fl1
->length
> fl2
->offset
1160 && fl2
->offset
+ fl2
->length
> fl1
->offset
)
1168 /* Return true if there is no possibility of aliasing because of a type
1169 mismatch between all the possible pointer references and the
1170 potential target. Note that this function is asymmetric in the
1171 arguments and so must be called twice with the arguments exchanged. */
1174 check_data_pointer_types (gfc_expr
*expr1
, gfc_expr
*expr2
)
1180 bool seen_component_ref
;
1182 if (expr1
->expr_type
!= EXPR_VARIABLE
1183 || expr2
->expr_type
!= EXPR_VARIABLE
)
1186 sym1
= expr1
->symtree
->n
.sym
;
1187 sym2
= expr2
->symtree
->n
.sym
;
1189 /* Keep it simple for now. */
1190 if (sym1
->ts
.type
== BT_DERIVED
&& sym2
->ts
.type
== BT_DERIVED
)
1193 if (sym1
->attr
.pointer
)
1195 if (gfc_compare_types (&sym1
->ts
, &sym2
->ts
))
1199 /* This is a conservative check on the components of the derived type
1200 if no component references have been seen. Since we will not dig
1201 into the components of derived type components, we play it safe by
1202 returning false. First we check the reference chain and then, if
1203 no component references have been seen, the components. */
1204 seen_component_ref
= false;
1205 if (sym1
->ts
.type
== BT_DERIVED
)
1207 for (ref1
= expr1
->ref
; ref1
; ref1
= ref1
->next
)
1209 if (ref1
->type
!= REF_COMPONENT
)
1212 if (ref1
->u
.c
.component
->ts
.type
== BT_DERIVED
)
1215 if ((sym2
->attr
.pointer
|| ref1
->u
.c
.component
->attr
.pointer
)
1216 && gfc_compare_types (&ref1
->u
.c
.component
->ts
, &sym2
->ts
))
1219 seen_component_ref
= true;
1223 if (sym1
->ts
.type
== BT_DERIVED
&& !seen_component_ref
)
1225 for (cm1
= sym1
->ts
.u
.derived
->components
; cm1
; cm1
= cm1
->next
)
1227 if (cm1
->ts
.type
== BT_DERIVED
)
1230 if ((sym2
->attr
.pointer
|| cm1
->attr
.pointer
)
1231 && gfc_compare_types (&cm1
->ts
, &sym2
->ts
))
1240 /* Return true if the statement body redefines the condition. Returns
1241 true if expr2 depends on expr1. expr1 should be a single term
1242 suitable for the lhs of an assignment. The IDENTICAL flag indicates
1243 whether array references to the same symbol with identical range
1244 references count as a dependency or not. Used for forall and where
1245 statements. Also used with functions returning arrays without a
1249 gfc_check_dependency (gfc_expr
*expr1
, gfc_expr
*expr2
, bool identical
)
1251 gfc_actual_arglist
*actual
;
1255 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1257 switch (expr2
->expr_type
)
1260 n
= gfc_check_dependency (expr1
, expr2
->value
.op
.op1
, identical
);
1263 if (expr2
->value
.op
.op2
)
1264 return gfc_check_dependency (expr1
, expr2
->value
.op
.op2
, identical
);
1268 /* The interesting cases are when the symbols don't match. */
1269 if (expr1
->symtree
->n
.sym
!= expr2
->symtree
->n
.sym
)
1271 symbol_attribute attr1
, attr2
;
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 /* We have to also include target-target as ptr%comp is not a
1288 pointer but it still alias with "dt%comp" for "ptr => dt". As
1289 subcomponents and array access to pointers retains the target
1290 attribute, that's sufficient. */
1291 attr1
= gfc_expr_attr (expr1
);
1292 attr2
= gfc_expr_attr (expr2
);
1293 if ((attr1
.pointer
|| attr1
.target
) && (attr2
.pointer
|| attr2
.target
))
1295 if (check_data_pointer_types (expr1
, expr2
)
1296 && check_data_pointer_types (expr2
, expr1
))
1303 gfc_symbol
*sym1
= expr1
->symtree
->n
.sym
;
1304 gfc_symbol
*sym2
= expr2
->symtree
->n
.sym
;
1305 if (sym1
->attr
.target
&& sym2
->attr
.target
1306 && ((sym1
->attr
.dummy
&& !sym1
->attr
.contiguous
1307 && (!sym1
->attr
.dimension
1308 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))
1309 || (sym2
->attr
.dummy
&& !sym2
->attr
.contiguous
1310 && (!sym2
->attr
.dimension
1311 || sym2
->as
->type
== AS_ASSUMED_SHAPE
))))
1315 /* Otherwise distinct symbols have no dependencies. */
1322 /* Identical and disjoint ranges return 0,
1323 overlapping ranges return 1. */
1324 if (expr1
->ref
&& expr2
->ref
)
1325 return gfc_dep_resolver (expr1
->ref
, expr2
->ref
, NULL
);
1330 if (gfc_get_noncopying_intrinsic_argument (expr2
) != NULL
)
1333 /* Remember possible differences between elemental and
1334 transformational functions. All functions inside a FORALL
1336 for (actual
= expr2
->value
.function
.actual
;
1337 actual
; actual
= actual
->next
)
1341 n
= gfc_check_dependency (expr1
, actual
->expr
, identical
);
1352 /* Loop through the array constructor's elements. */
1353 for (c
= gfc_constructor_first (expr2
->value
.constructor
);
1354 c
; c
= gfc_constructor_next (c
))
1356 /* If this is an iterator, assume the worst. */
1359 /* Avoid recursion in the common case. */
1360 if (c
->expr
->expr_type
== EXPR_CONSTANT
)
1362 if (gfc_check_dependency (expr1
, c
->expr
, 1))
1373 /* Determines overlapping for two array sections. */
1375 static gfc_dependency
1376 check_section_vs_section (gfc_array_ref
*l_ar
, gfc_array_ref
*r_ar
, int n
)
1392 int stride_comparison
;
1393 int start_comparison
;
1396 /* If they are the same range, return without more ado. */
1397 if (is_same_range (l_ar
, r_ar
, n
))
1398 return GFC_DEP_EQUAL
;
1400 l_start
= l_ar
->start
[n
];
1401 l_end
= l_ar
->end
[n
];
1402 l_stride
= l_ar
->stride
[n
];
1404 r_start
= r_ar
->start
[n
];
1405 r_end
= r_ar
->end
[n
];
1406 r_stride
= r_ar
->stride
[n
];
1408 /* If l_start is NULL take it from array specifier. */
1409 if (NULL
== l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1410 l_start
= l_ar
->as
->lower
[n
];
1411 /* If l_end is NULL take it from array specifier. */
1412 if (NULL
== l_end
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1413 l_end
= l_ar
->as
->upper
[n
];
1415 /* If r_start is NULL take it from array specifier. */
1416 if (NULL
== r_start
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1417 r_start
= r_ar
->as
->lower
[n
];
1418 /* If r_end is NULL take it from array specifier. */
1419 if (NULL
== r_end
&& IS_ARRAY_EXPLICIT (r_ar
->as
))
1420 r_end
= r_ar
->as
->upper
[n
];
1422 /* Determine whether the l_stride is positive or negative. */
1425 else if (l_stride
->expr_type
== EXPR_CONSTANT
1426 && l_stride
->ts
.type
== BT_INTEGER
)
1427 l_dir
= mpz_sgn (l_stride
->value
.integer
);
1428 else if (l_start
&& l_end
)
1429 l_dir
= gfc_dep_compare_expr (l_end
, l_start
);
1433 /* Determine whether the r_stride is positive or negative. */
1436 else if (r_stride
->expr_type
== EXPR_CONSTANT
1437 && r_stride
->ts
.type
== BT_INTEGER
)
1438 r_dir
= mpz_sgn (r_stride
->value
.integer
);
1439 else if (r_start
&& r_end
)
1440 r_dir
= gfc_dep_compare_expr (r_end
, r_start
);
1444 /* The strides should never be zero. */
1445 if (l_dir
== 0 || r_dir
== 0)
1446 return GFC_DEP_OVERLAP
;
1448 /* Determine the relationship between the strides. Set stride_comparison to
1449 -2 if the dependency cannot be determined
1450 -1 if l_stride < r_stride
1451 0 if l_stride == r_stride
1452 1 if l_stride > r_stride
1453 as determined by gfc_dep_compare_expr. */
1455 one_expr
= gfc_get_int_expr (gfc_index_integer_kind
, NULL
, 1);
1457 stride_comparison
= gfc_dep_compare_expr (l_stride
? l_stride
: one_expr
,
1458 r_stride
? r_stride
: one_expr
);
1460 if (l_start
&& r_start
)
1461 start_comparison
= gfc_dep_compare_expr (l_start
, r_start
);
1463 start_comparison
= -2;
1465 gfc_free_expr (one_expr
);
1467 /* Determine LHS upper and lower bounds. */
1473 else if (l_dir
== -1)
1484 /* Determine RHS upper and lower bounds. */
1490 else if (r_dir
== -1)
1501 /* Check whether the ranges are disjoint. */
1502 if (l_upper
&& r_lower
&& gfc_dep_compare_expr (l_upper
, r_lower
) == -1)
1503 return GFC_DEP_NODEP
;
1504 if (r_upper
&& l_lower
&& gfc_dep_compare_expr (r_upper
, l_lower
) == -1)
1505 return GFC_DEP_NODEP
;
1507 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1508 if (l_start
&& r_start
&& gfc_dep_compare_expr (l_start
, r_start
) == 0)
1510 if (l_dir
== 1 && r_dir
== -1)
1511 return GFC_DEP_EQUAL
;
1512 if (l_dir
== -1 && r_dir
== 1)
1513 return GFC_DEP_EQUAL
;
1516 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1517 if (l_end
&& r_end
&& gfc_dep_compare_expr (l_end
, r_end
) == 0)
1519 if (l_dir
== 1 && r_dir
== -1)
1520 return GFC_DEP_EQUAL
;
1521 if (l_dir
== -1 && r_dir
== 1)
1522 return GFC_DEP_EQUAL
;
1525 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1526 There is no dependency if the remainder of
1527 (l_start - r_start) / gcd(l_stride, r_stride) is
1530 - Cases like a(1:4:2) = a(2:3) are still not handled.
1533 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1534 && (a)->ts.type == BT_INTEGER)
1536 if (IS_CONSTANT_INTEGER (l_stride
) && IS_CONSTANT_INTEGER (r_stride
)
1537 && gfc_dep_difference (l_start
, r_start
, &tmp
))
1543 mpz_gcd (gcd
, l_stride
->value
.integer
, r_stride
->value
.integer
);
1545 mpz_fdiv_r (tmp
, tmp
, gcd
);
1546 result
= mpz_cmp_si (tmp
, 0L);
1552 return GFC_DEP_NODEP
;
1555 #undef IS_CONSTANT_INTEGER
1557 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1559 if (l_dir
== 1 && r_dir
== 1 &&
1560 (start_comparison
== 0 || start_comparison
== -1)
1561 && (stride_comparison
== 0 || stride_comparison
== -1))
1562 return GFC_DEP_FORWARD
;
1564 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1565 x:y:-1 vs. x:y:-2. */
1566 if (l_dir
== -1 && r_dir
== -1 &&
1567 (start_comparison
== 0 || start_comparison
== 1)
1568 && (stride_comparison
== 0 || stride_comparison
== 1))
1569 return GFC_DEP_FORWARD
;
1571 if (stride_comparison
== 0 || stride_comparison
== -1)
1573 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1576 /* Check for a(low:y:s) vs. a(z:x:s) or
1577 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1578 of low, which is always at least a forward dependence. */
1581 && gfc_dep_compare_expr (l_start
, l_ar
->as
->lower
[n
]) == 0)
1582 return GFC_DEP_FORWARD
;
1586 if (stride_comparison
== 0 || stride_comparison
== 1)
1588 if (l_start
&& IS_ARRAY_EXPLICIT (l_ar
->as
))
1591 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1592 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1593 of high, which is always at least a forward dependence. */
1596 && gfc_dep_compare_expr (l_start
, l_ar
->as
->upper
[n
]) == 0)
1597 return GFC_DEP_FORWARD
;
1602 if (stride_comparison
== 0)
1604 /* From here, check for backwards dependencies. */
1605 /* x+1:y vs. x:z. */
1606 if (l_dir
== 1 && r_dir
== 1 && start_comparison
== 1)
1607 return GFC_DEP_BACKWARD
;
1609 /* x-1:y:-1 vs. x:z:-1. */
1610 if (l_dir
== -1 && r_dir
== -1 && start_comparison
== -1)
1611 return GFC_DEP_BACKWARD
;
1614 return GFC_DEP_OVERLAP
;
1618 /* Determines overlapping for a single element and a section. */
1620 static gfc_dependency
1621 gfc_check_element_vs_section( gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1630 elem
= lref
->u
.ar
.start
[n
];
1632 return GFC_DEP_OVERLAP
;
1635 start
= ref
->start
[n
] ;
1637 stride
= ref
->stride
[n
];
1639 if (!start
&& IS_ARRAY_EXPLICIT (ref
->as
))
1640 start
= ref
->as
->lower
[n
];
1641 if (!end
&& IS_ARRAY_EXPLICIT (ref
->as
))
1642 end
= ref
->as
->upper
[n
];
1644 /* Determine whether the stride is positive or negative. */
1647 else if (stride
->expr_type
== EXPR_CONSTANT
1648 && stride
->ts
.type
== BT_INTEGER
)
1649 s
= mpz_sgn (stride
->value
.integer
);
1653 /* Stride should never be zero. */
1655 return GFC_DEP_OVERLAP
;
1657 /* Positive strides. */
1660 /* Check for elem < lower. */
1661 if (start
&& gfc_dep_compare_expr (elem
, start
) == -1)
1662 return GFC_DEP_NODEP
;
1663 /* Check for elem > upper. */
1664 if (end
&& gfc_dep_compare_expr (elem
, end
) == 1)
1665 return GFC_DEP_NODEP
;
1669 s
= gfc_dep_compare_expr (start
, end
);
1670 /* Check for an empty range. */
1672 return GFC_DEP_NODEP
;
1673 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1674 return GFC_DEP_EQUAL
;
1677 /* Negative strides. */
1680 /* Check for elem > upper. */
1681 if (end
&& gfc_dep_compare_expr (elem
, start
) == 1)
1682 return GFC_DEP_NODEP
;
1683 /* Check for elem < lower. */
1684 if (start
&& gfc_dep_compare_expr (elem
, end
) == -1)
1685 return GFC_DEP_NODEP
;
1689 s
= gfc_dep_compare_expr (start
, end
);
1690 /* Check for an empty range. */
1692 return GFC_DEP_NODEP
;
1693 if (s
== 0 && gfc_dep_compare_expr (elem
, start
) == 0)
1694 return GFC_DEP_EQUAL
;
1697 /* Unknown strides. */
1701 return GFC_DEP_OVERLAP
;
1702 s
= gfc_dep_compare_expr (start
, end
);
1704 return GFC_DEP_OVERLAP
;
1705 /* Assume positive stride. */
1708 /* Check for elem < lower. */
1709 if (gfc_dep_compare_expr (elem
, start
) == -1)
1710 return GFC_DEP_NODEP
;
1711 /* Check for elem > upper. */
1712 if (gfc_dep_compare_expr (elem
, end
) == 1)
1713 return GFC_DEP_NODEP
;
1715 /* Assume negative stride. */
1718 /* Check for elem > upper. */
1719 if (gfc_dep_compare_expr (elem
, start
) == 1)
1720 return GFC_DEP_NODEP
;
1721 /* Check for elem < lower. */
1722 if (gfc_dep_compare_expr (elem
, end
) == -1)
1723 return GFC_DEP_NODEP
;
1728 s
= gfc_dep_compare_expr (elem
, start
);
1730 return GFC_DEP_EQUAL
;
1731 if (s
== 1 || s
== -1)
1732 return GFC_DEP_NODEP
;
1736 return GFC_DEP_OVERLAP
;
1740 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1741 forall_index attribute. Return true if any variable may be
1742 being used as a FORALL index. Its safe to pessimistically
1743 return true, and assume a dependency. */
1746 contains_forall_index_p (gfc_expr
*expr
)
1748 gfc_actual_arglist
*arg
;
1756 switch (expr
->expr_type
)
1759 if (expr
->symtree
->n
.sym
->forall_index
)
1764 if (contains_forall_index_p (expr
->value
.op
.op1
)
1765 || contains_forall_index_p (expr
->value
.op
.op2
))
1770 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
1771 if (contains_forall_index_p (arg
->expr
))
1777 case EXPR_SUBSTRING
:
1780 case EXPR_STRUCTURE
:
1782 for (c
= gfc_constructor_first (expr
->value
.constructor
);
1783 c
; gfc_constructor_next (c
))
1784 if (contains_forall_index_p (c
->expr
))
1792 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
1796 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1797 if (contains_forall_index_p (ref
->u
.ar
.start
[i
])
1798 || contains_forall_index_p (ref
->u
.ar
.end
[i
])
1799 || contains_forall_index_p (ref
->u
.ar
.stride
[i
]))
1807 if (contains_forall_index_p (ref
->u
.ss
.start
)
1808 || contains_forall_index_p (ref
->u
.ss
.end
))
1819 /* Determines overlapping for two single element array references. */
1821 static gfc_dependency
1822 gfc_check_element_vs_element (gfc_ref
*lref
, gfc_ref
*rref
, int n
)
1832 l_start
= l_ar
.start
[n
] ;
1833 r_start
= r_ar
.start
[n
] ;
1834 i
= gfc_dep_compare_expr (r_start
, l_start
);
1836 return GFC_DEP_EQUAL
;
1838 /* Treat two scalar variables as potentially equal. This allows
1839 us to prove that a(i,:) and a(j,:) have no dependency. See
1840 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1841 Proceedings of the International Conference on Parallel and
1842 Distributed Processing Techniques and Applications (PDPTA2001),
1843 Las Vegas, Nevada, June 2001. */
1844 /* However, we need to be careful when either scalar expression
1845 contains a FORALL index, as these can potentially change value
1846 during the scalarization/traversal of this array reference. */
1847 if (contains_forall_index_p (r_start
) || contains_forall_index_p (l_start
))
1848 return GFC_DEP_OVERLAP
;
1851 return GFC_DEP_NODEP
;
1852 return GFC_DEP_EQUAL
;
1855 /* Callback function for checking if an expression depends on a
1856 dummy variable which is any other than INTENT(IN). */
1859 callback_dummy_intent_not_in (gfc_expr
**ep
,
1860 int *walk_subtrees ATTRIBUTE_UNUSED
,
1861 void *data ATTRIBUTE_UNUSED
)
1865 if (e
->expr_type
== EXPR_VARIABLE
&& e
->symtree
1866 && e
->symtree
->n
.sym
->attr
.dummy
)
1867 return e
->symtree
->n
.sym
->attr
.intent
!= INTENT_IN
;
1872 /* Auxiliary function to check if subexpressions have dummy variables which
1877 dummy_intent_not_in (gfc_expr
**ep
)
1879 return gfc_expr_walker (ep
, callback_dummy_intent_not_in
, NULL
);
1882 /* Determine if an array ref, usually an array section specifies the
1883 entire array. In addition, if the second, pointer argument is
1884 provided, the function will return true if the reference is
1885 contiguous; eg. (:, 1) gives true but (1,:) gives false.
1886 If one of the bounds depends on a dummy variable which is
1887 not INTENT(IN), also return false, because the user may
1888 have changed the variable. */
1891 gfc_full_array_ref_p (gfc_ref
*ref
, bool *contiguous
)
1895 bool lbound_OK
= true;
1896 bool ubound_OK
= true;
1899 *contiguous
= false;
1901 if (ref
->type
!= REF_ARRAY
)
1904 if (ref
->u
.ar
.type
== AR_FULL
)
1911 if (ref
->u
.ar
.type
!= AR_SECTION
)
1916 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1918 /* If we have a single element in the reference, for the reference
1919 to be full, we need to ascertain that the array has a single
1920 element in this dimension and that we actually reference the
1922 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
1924 /* This is unconditionally a contiguous reference if all the
1925 remaining dimensions are elements. */
1929 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1930 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1931 *contiguous
= false;
1935 || !ref
->u
.ar
.as
->lower
[i
]
1936 || !ref
->u
.ar
.as
->upper
[i
]
1937 || gfc_dep_compare_expr (ref
->u
.ar
.as
->lower
[i
],
1938 ref
->u
.ar
.as
->upper
[i
])
1939 || !ref
->u
.ar
.start
[i
]
1940 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1941 ref
->u
.ar
.as
->lower
[i
]))
1947 /* Check the lower bound. */
1948 if (ref
->u
.ar
.start
[i
]
1950 || !ref
->u
.ar
.as
->lower
[i
]
1951 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
1952 ref
->u
.ar
.as
->lower
[i
])
1953 || dummy_intent_not_in (&ref
->u
.ar
.start
[i
])))
1955 /* Check the upper bound. */
1956 if (ref
->u
.ar
.end
[i
]
1958 || !ref
->u
.ar
.as
->upper
[i
]
1959 || gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
1960 ref
->u
.ar
.as
->upper
[i
])
1961 || dummy_intent_not_in (&ref
->u
.ar
.end
[i
])))
1963 /* Check the stride. */
1964 if (ref
->u
.ar
.stride
[i
]
1965 && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
1968 /* This is unconditionally a contiguous reference as long as all
1969 the subsequent dimensions are elements. */
1973 for (n
= i
+ 1; n
< ref
->u
.ar
.dimen
; n
++)
1974 if (ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
1975 *contiguous
= false;
1978 if (!lbound_OK
|| !ubound_OK
)
1985 /* Determine if a full array is the same as an array section with one
1986 variable limit. For this to be so, the strides must both be unity
1987 and one of either start == lower or end == upper must be true. */
1990 ref_same_as_full_array (gfc_ref
*full_ref
, gfc_ref
*ref
)
1993 bool upper_or_lower
;
1995 if (full_ref
->type
!= REF_ARRAY
)
1997 if (full_ref
->u
.ar
.type
!= AR_FULL
)
1999 if (ref
->type
!= REF_ARRAY
)
2001 if (ref
->u
.ar
.type
!= AR_SECTION
)
2004 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2006 /* If we have a single element in the reference, we need to check
2007 that the array has a single element and that we actually reference
2008 the correct element. */
2009 if (ref
->u
.ar
.dimen_type
[i
] == DIMEN_ELEMENT
)
2011 if (!full_ref
->u
.ar
.as
2012 || !full_ref
->u
.ar
.as
->lower
[i
]
2013 || !full_ref
->u
.ar
.as
->upper
[i
]
2014 || gfc_dep_compare_expr (full_ref
->u
.ar
.as
->lower
[i
],
2015 full_ref
->u
.ar
.as
->upper
[i
])
2016 || !ref
->u
.ar
.start
[i
]
2017 || gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
2018 full_ref
->u
.ar
.as
->lower
[i
]))
2022 /* Check the strides. */
2023 if (full_ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (full_ref
->u
.ar
.stride
[i
], 0))
2025 if (ref
->u
.ar
.stride
[i
] && !gfc_expr_is_one (ref
->u
.ar
.stride
[i
], 0))
2028 upper_or_lower
= false;
2029 /* Check the lower bound. */
2030 if (ref
->u
.ar
.start
[i
]
2032 && full_ref
->u
.ar
.as
->lower
[i
]
2033 && gfc_dep_compare_expr (ref
->u
.ar
.start
[i
],
2034 full_ref
->u
.ar
.as
->lower
[i
]) == 0))
2035 upper_or_lower
= true;
2036 /* Check the upper bound. */
2037 if (ref
->u
.ar
.end
[i
]
2039 && full_ref
->u
.ar
.as
->upper
[i
]
2040 && gfc_dep_compare_expr (ref
->u
.ar
.end
[i
],
2041 full_ref
->u
.ar
.as
->upper
[i
]) == 0))
2042 upper_or_lower
= true;
2043 if (!upper_or_lower
)
2050 /* Finds if two array references are overlapping or not.
2052 2 : array references are overlapping but reversal of one or
2053 more dimensions will clear the dependency.
2054 1 : array references are overlapping.
2055 0 : array references are identical or not overlapping. */
2058 gfc_dep_resolver (gfc_ref
*lref
, gfc_ref
*rref
, gfc_reverse
*reverse
)
2062 gfc_dependency fin_dep
;
2063 gfc_dependency this_dep
;
2065 this_dep
= GFC_DEP_ERROR
;
2066 fin_dep
= GFC_DEP_ERROR
;
2067 /* Dependencies due to pointers should already have been identified.
2068 We only need to check for overlapping array references. */
2070 while (lref
&& rref
)
2072 /* We're resolving from the same base symbol, so both refs should be
2073 the same type. We traverse the reference chain until we find ranges
2074 that are not equal. */
2075 gcc_assert (lref
->type
== rref
->type
);
2079 /* The two ranges can't overlap if they are from different
2081 if (lref
->u
.c
.component
!= rref
->u
.c
.component
)
2086 /* Substring overlaps are handled by the string assignment code
2087 if there is not an underlying dependency. */
2088 return (fin_dep
== GFC_DEP_OVERLAP
) ? 1 : 0;
2092 if (ref_same_as_full_array (lref
, rref
))
2095 if (ref_same_as_full_array (rref
, lref
))
2098 if (lref
->u
.ar
.dimen
!= rref
->u
.ar
.dimen
)
2100 if (lref
->u
.ar
.type
== AR_FULL
)
2101 fin_dep
= gfc_full_array_ref_p (rref
, NULL
) ? GFC_DEP_EQUAL
2103 else if (rref
->u
.ar
.type
== AR_FULL
)
2104 fin_dep
= gfc_full_array_ref_p (lref
, NULL
) ? GFC_DEP_EQUAL
2111 /* Index for the reverse array. */
2113 for (n
=0; n
< lref
->u
.ar
.dimen
; n
++)
2115 /* Handle dependency when either of array reference is vector
2116 subscript. There is no dependency if the vector indices
2117 are equal or if indices are known to be different in a
2118 different dimension. */
2119 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2120 || rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
)
2122 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2123 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_VECTOR
2124 && gfc_dep_compare_expr (lref
->u
.ar
.start
[n
],
2125 rref
->u
.ar
.start
[n
]) == 0)
2126 this_dep
= GFC_DEP_EQUAL
;
2128 this_dep
= GFC_DEP_OVERLAP
;
2130 goto update_fin_dep
;
2133 if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2134 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2135 this_dep
= check_section_vs_section (&lref
->u
.ar
, &rref
->u
.ar
, n
);
2136 else if (lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2137 && rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2138 this_dep
= gfc_check_element_vs_section (lref
, rref
, n
);
2139 else if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2140 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2141 this_dep
= gfc_check_element_vs_section (rref
, lref
, n
);
2144 gcc_assert (rref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
2145 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_ELEMENT
);
2146 this_dep
= gfc_check_element_vs_element (rref
, lref
, n
);
2149 /* If any dimension doesn't overlap, we have no dependency. */
2150 if (this_dep
== GFC_DEP_NODEP
)
2153 /* Now deal with the loop reversal logic: This only works on
2154 ranges and is activated by setting
2155 reverse[n] == GFC_ENABLE_REVERSE
2156 The ability to reverse or not is set by previous conditions
2157 in this dimension. If reversal is not activated, the
2158 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2160 /* Get the indexing right for the scalarizing loop. If this
2161 is an element, there is no corresponding loop. */
2162 if (lref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
2165 if (rref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
2166 && lref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
2168 /* Set reverse if backward dependence and not inhibited. */
2169 if (reverse
&& reverse
[m
] == GFC_ENABLE_REVERSE
)
2170 reverse
[m
] = (this_dep
== GFC_DEP_BACKWARD
) ?
2171 GFC_REVERSE_SET
: reverse
[m
];
2173 /* Set forward if forward dependence and not inhibited. */
2174 if (reverse
&& reverse
[m
] == GFC_ENABLE_REVERSE
)
2175 reverse
[m
] = (this_dep
== GFC_DEP_FORWARD
) ?
2176 GFC_FORWARD_SET
: reverse
[m
];
2178 /* Flag up overlap if dependence not compatible with
2179 the overall state of the expression. */
2180 if (reverse
&& reverse
[m
] == GFC_REVERSE_SET
2181 && this_dep
== GFC_DEP_FORWARD
)
2183 reverse
[m
] = GFC_INHIBIT_REVERSE
;
2184 this_dep
= GFC_DEP_OVERLAP
;
2186 else if (reverse
&& reverse
[m
] == GFC_FORWARD_SET
2187 && this_dep
== GFC_DEP_BACKWARD
)
2189 reverse
[m
] = GFC_INHIBIT_REVERSE
;
2190 this_dep
= GFC_DEP_OVERLAP
;
2193 /* If no intention of reversing or reversing is explicitly
2194 inhibited, convert backward dependence to overlap. */
2195 if ((reverse
== NULL
&& this_dep
== GFC_DEP_BACKWARD
)
2196 || (reverse
!= NULL
&& reverse
[m
] == GFC_INHIBIT_REVERSE
))
2197 this_dep
= GFC_DEP_OVERLAP
;
2200 /* Overlap codes are in order of priority. We only need to
2201 know the worst one.*/
2204 if (this_dep
> fin_dep
)
2208 /* If this is an equal element, we have to keep going until we find
2209 the "real" array reference. */
2210 if (lref
->u
.ar
.type
== AR_ELEMENT
2211 && rref
->u
.ar
.type
== AR_ELEMENT
2212 && fin_dep
== GFC_DEP_EQUAL
)
2215 /* Exactly matching and forward overlapping ranges don't cause a
2217 if (fin_dep
< GFC_DEP_BACKWARD
)
2220 /* Keep checking. We only have a dependency if
2221 subsequent references also overlap. */
2231 /* If we haven't seen any array refs then something went wrong. */
2232 gcc_assert (fin_dep
!= GFC_DEP_ERROR
);
2234 /* Assume the worst if we nest to different depths. */
2238 return fin_dep
== GFC_DEP_OVERLAP
;