?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Don't warn when alignment of global common data exceeds maximum alignment.
[official-gcc.git] / gcc / fortran / dependency.c
blobe1336e1c65458b4606c283f01051a3269b828487
1 /* Dependency analysis
2 Copyright (C) 2000-2021 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of GCC.
6
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
10 version.
11
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
15 for more details.
16
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/>. */
20
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. */
25
26 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "gfortran.h"
30 #include "dependency.h"
31 #include "constructor.h"
32 #include "arith.h"
33 #include "options.h"
34
35 /* static declarations */
36 /* Enums */
37 enum range {LHS, RHS, MID};
38
39 /* Dependency types. These must be in reverse order of priority. */
40 enum gfc_dependency
41 {
42 GFC_DEP_ERROR,
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. */
48 };
49
50 /* Macros */
51 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
52
53 /* Forward declarations */
54
55 static gfc_dependency check_section_vs_section (gfc_array_ref *,
56 gfc_array_ref *, int);
57
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. */
60
61 int
62 gfc_expr_is_one (gfc_expr *expr, int def)
63 {
64 gcc_assert (expr != NULL);
65
66 if (expr->expr_type != EXPR_CONSTANT)
67 return def;
68
69 if (expr->ts.type != BT_INTEGER)
70 return def;
71
72 return mpz_cmp_si (expr->value.integer, 1) == 0;
73 }
74
75 /* Check if two array references are known to be identical. Calls
76 gfc_dep_compare_expr if necessary for comparing array indices. */
77
78 static bool
79 identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
80 {
81 int i;
82
83 if (a1->type == AR_FULL && a2->type == AR_FULL)
84 return true;
85
86 if (a1->type == AR_SECTION && a2->type == AR_SECTION)
87 {
88 gcc_assert (a1->dimen == a2->dimen);
89
90 for ( i = 0; i < a1->dimen; i++)
91 {
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)
95 return false;
96
97 if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL)
98 return false;
99 }
100 return true;
101 }
102
103 if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
104 {
105 if (a1->dimen != a2->dimen)
106 gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
107
108 for (i = 0; i < a1->dimen; i++)
109 {
110 if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0)
111 return false;
112 }
113 return true;
114 }
115 return false;
116 }
117
118
119
120 /* Return true for identical variables, checking for references if
121 necessary. Calls identical_array_ref for checking array sections. */
122
123 static bool
124 are_identical_variables (gfc_expr *e1, gfc_expr *e2)
125 {
126 gfc_ref *r1, *r2;
127
128 if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
129 {
130 /* Dummy arguments: Only check for equal names. */
131 if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
132 return false;
133 }
134 else
135 {
136 /* Check for equal symbols. */
137 if (e1->symtree->n.sym != e2->symtree->n.sym)
138 return false;
139 }
140
141 /* Volatile variables should never compare equal to themselves. */
142
143 if (e1->symtree->n.sym->attr.volatile_)
144 return false;
145
146 r1 = e1->ref;
147 r2 = e2->ref;
148
149 while (r1 != NULL || r2 != NULL)
150 {
151
152 /* Assume the variables are not equal if one has a reference and the
153 other doesn't.
154 TODO: Handle full references like comparing a(:) to a.
155 */
156
157 if (r1 == NULL || r2 == NULL)
158 return false;
159
160 if (r1->type != r2->type)
161 return false;
162
163 switch (r1->type)
164 {
165
166 case REF_ARRAY:
167 if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
168 return false;
169
170 break;
171
172 case REF_COMPONENT:
173 if (r1->u.c.component != r2->u.c.component)
174 return false;
175 break;
176
177 case REF_SUBSTRING:
178 if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0)
179 return false;
180
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. */
184
185 if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
186 break;
187
188 if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
189 return false;
190
191 break;
192
193 case REF_INQUIRY:
194 if (r1->u.i != r2->u.i)
195 return false;
196 break;
197
198 default:
199 gfc_internal_error ("are_identical_variables: Bad type");
200 }
201 r1 = r1->next;
202 r2 = r2->next;
203 }
204 return true;
205 }
206
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. */
209
210 int
211 gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
212 {
213
214 gfc_actual_arglist *args1;
215 gfc_actual_arglist *args2;
216
217 if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
218 return -2;
219
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)))
226 {
227 args1 = e1->value.function.actual;
228 args2 = e2->value.function.actual;
229
230 /* Compare the argument lists for equality. */
231 while (args1 && args2)
232 {
233 /* Bitwise xor, since C has no non-bitwise xor operator. */
234 if ((args1->expr == NULL) ^ (args2->expr == NULL))
235 return -2;
236
237 if (args1->expr != NULL && args2->expr != NULL)
238 {
239 gfc_expr *e1, *e2;
240 e1 = args1->expr;
241 e2 = args2->expr;
242
243 if (gfc_dep_compare_expr (e1, e2) != 0)
244 return -2;
245
246 /* Special case: String arguments which compare equal can have
247 different lengths, which makes them different in calls to
248 procedures. */
249
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)
255 return -2;
256 }
257
258 args1 = args1->next;
259 args2 = args2->next;
260 }
261 return (args1 || args2) ? -2 : 0;
262 }
263 else
264 return -2;
265 }
266
267 /* Helper function to look through parens, unary plus and widening
268 integer conversions. */
269
270 gfc_expr *
271 gfc_discard_nops (gfc_expr *e)
272 {
273 gfc_actual_arglist *arglist;
274
275 if (e == NULL)
276 return NULL;
277
278 while (true)
279 {
280 if (e->expr_type == EXPR_OP
281 && (e->value.op.op == INTRINSIC_UPLUS
282 || e->value.op.op == INTRINSIC_PARENTHESES))
283 {
284 e = e->value.op.op1;
285 continue;
286 }
287
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)
291 {
292 arglist = e->value.function.actual;
293 if (arglist->expr->ts.type == BT_INTEGER
294 && e->ts.kind > arglist->expr->ts.kind)
295 {
296 e = arglist->expr;
297 continue;
298 }
299 }
300 break;
301 }
302
303 return e;
304 }
305
306
307 /* Compare two expressions. Return values:
308 * +1 if e1 > e2
309 * 0 if e1 == e2
310 * -1 if e1 < e2
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. */
315
316 int
317 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
318 {
319 int i;
320
321 if (e1 == NULL && e2 == NULL)
322 return 0;
323 else if (e1 == NULL || e2 == NULL)
324 return -2;
325
326 e1 = gfc_discard_nops (e1);
327 e2 = gfc_discard_nops (e2);
328
329 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
330 {
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);
336
337 /* Compare P+Q vs. R+S. */
338 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
339 {
340 int l, r;
341
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)
345 return 0;
346 if (l == 0 && r > -2)
347 return r;
348 if (l > -2 && r == 0)
349 return l;
350 if (l == 1 && r == 1)
351 return 1;
352 if (l == -1 && r == -1)
353 return -1;
354
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)
358 return 0;
359 if (l == 0 && r > -2)
360 return r;
361 if (l > -2 && r == 0)
362 return l;
363 if (l == 1 && r == 1)
364 return 1;
365 if (l == -1 && r == -1)
366 return -1;
367 }
368 }
369
370 /* Compare X vs. X+C, for INTEGER only. */
371 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
372 {
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);
377 }
378
379 /* Compare X-C vs. X, for INTEGER only. */
380 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
381 {
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);
386
387 /* Compare P-Q vs. R-S. */
388 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
389 {
390 int l, r;
391
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)
395 return 0;
396 if (l > -2 && r == 0)
397 return l;
398 if (l == 0 && r > -2)
399 return -r;
400 if (l == 1 && r == -1)
401 return 1;
402 if (l == -1 && r == 1)
403 return -1;
404 }
405 }
406
407 /* Compare A // B vs. C // D. */
408
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)
411 {
412 int l, r;
413
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);
416
417 if (l != 0)
418 return l;
419
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;
424
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)
429 return -2;
430 else
431 return r;
432 }
433
434 /* Compare X vs. X-C, for INTEGER only. */
435 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
436 {
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);
441 }
442
443 if (e1->expr_type != e2->expr_type)
444 return -3;
445
446 switch (e1->expr_type)
447 {
448 case EXPR_CONSTANT:
449 /* Compare strings for equality. */
450 if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
451 return gfc_compare_string (e1, e2);
452
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)
457 {
458 if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
459 {
460 if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
461 return 0;
462 else
463 return -2;
464 }
465 else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX)
466 {
467 if (mpc_cmp (e1->value.complex, e2->value.complex) == 0)
468 return 0;
469 else
470 return -2;
471 }
472 }
473
474 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
475 return -2;
476
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);
480
481 i = mpz_cmp (e1->value.integer, e2->value.integer);
482 if (i == 0)
483 return 0;
484 else if (i < 0)
485 return -1;
486 return 1;
487
488 case EXPR_VARIABLE:
489 if (are_identical_variables (e1, e2))
490 return 0;
491 else
492 return -3;
493
494 case EXPR_OP:
495 /* Intrinsic operators are the same if their operands are the same. */
496 if (e1->value.op.op != e2->value.op.op)
497 return -2;
498 if (e1->value.op.op2 == 0)
499 {
500 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
501 return i == 0 ? 0 : -2;
502 }
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)
505 return 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. */
510 return 0;
511
512 return -2;
513
514 case EXPR_FUNCTION:
515 return gfc_dep_compare_functions (e1, e2, false);
516
517 default:
518 return -2;
519 }
520 }
521
522
523 /* Return the difference between two expressions. Integer expressions of
524 the form
525
526 X + constant, X - constant and constant + X
527
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.
530 */
531
532 bool
533 gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
534 {
535 gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
536
537 if (e1 == NULL || e2 == NULL)
538 return false;
539
540 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
541 return false;
542
543 e1 = gfc_discard_nops (e1);
544 e2 = gfc_discard_nops (e2);
545
546 /* Inizialize tentatively, clear if we don't return anything. */
547 mpz_init (*result);
548
549 /* Case 1: c1 - c2 = c1 - c2, trivially. */
550
551 if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
552 {
553 mpz_sub (*result, e1->value.integer, e2->value.integer);
554 return true;
555 }
556
557 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
558 {
559 e1_op1 = gfc_discard_nops (e1->value.op.op1);
560 e1_op2 = gfc_discard_nops (e1->value.op.op2);
561
562 /* Case 2: (X + c1) - X = c1. */
563 if (e1_op2->expr_type == EXPR_CONSTANT
564 && gfc_dep_compare_expr (e1_op1, e2) == 0)
565 {
566 mpz_set (*result, e1_op2->value.integer);
567 return true;
568 }
569
570 /* Case 3: (c1 + X) - X = c1. */
571 if (e1_op1->expr_type == EXPR_CONSTANT
572 && gfc_dep_compare_expr (e1_op2, e2) == 0)
573 {
574 mpz_set (*result, e1_op1->value.integer);
575 return true;
576 }
577
578 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
579 {
580 e2_op1 = gfc_discard_nops (e2->value.op.op1);
581 e2_op2 = gfc_discard_nops (e2->value.op.op2);
582
583 if (e1_op2->expr_type == EXPR_CONSTANT)
584 {
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)
588 {
589 mpz_sub (*result, e1_op2->value.integer,
590 e2_op2->value.integer);
591 return true;
592 }
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)
596 {
597 mpz_sub (*result, e1_op2->value.integer,
598 e2_op1->value.integer);
599 return true;
600 }
601 }
602 else if (e1_op1->expr_type == EXPR_CONSTANT)
603 {
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)
607 {
608 mpz_sub (*result, e1_op1->value.integer,
609 e2_op2->value.integer);
610 return true;
611 }
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)
615 {
616 mpz_sub (*result, e1_op1->value.integer,
617 e2_op1->value.integer);
618 return true;
619 }
620 }
621 }
622
623 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
624 {
625 e2_op1 = gfc_discard_nops (e2->value.op.op1);
626 e2_op2 = gfc_discard_nops (e2->value.op.op2);
627
628 if (e1_op2->expr_type == EXPR_CONSTANT)
629 {
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)
633 {
634 mpz_add (*result, e1_op2->value.integer,
635 e2_op2->value.integer);
636 return true;
637 }
638 }
639 if (e1_op1->expr_type == EXPR_CONSTANT)
640 {
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)
644 {
645 mpz_add (*result, e1_op1->value.integer,
646 e2_op2->value.integer);
647 return true;
648 }
649 }
650 }
651 }
652
653 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
654 {
655 e1_op1 = gfc_discard_nops (e1->value.op.op1);
656 e1_op2 = gfc_discard_nops (e1->value.op.op2);
657
658 if (e1_op2->expr_type == EXPR_CONSTANT)
659 {
660 /* Case 10: (X - c1) - X = -c1 */
661
662 if (gfc_dep_compare_expr (e1_op1, e2) == 0)
663 {
664 mpz_neg (*result, e1_op2->value.integer);
665 return true;
666 }
667
668 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
669 {
670 e2_op1 = gfc_discard_nops (e2->value.op.op1);
671 e2_op2 = gfc_discard_nops (e2->value.op.op2);
672
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)
676 {
677 mpz_add (*result, e1_op2->value.integer,
678 e2_op2->value.integer);
679 mpz_neg (*result, *result);
680 return true;
681 }
682
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)
686 {
687 mpz_add (*result, e1_op2->value.integer,
688 e2_op1->value.integer);
689 mpz_neg (*result, *result);
690 return true;
691 }
692 }
693
694 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
695 {
696 e2_op1 = gfc_discard_nops (e2->value.op.op1);
697 e2_op2 = gfc_discard_nops (e2->value.op.op2);
698
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)
702 {
703 mpz_sub (*result, e2_op2->value.integer,
704 e1_op2->value.integer);
705 return true;
706 }
707 }
708 }
709 if (e1_op1->expr_type == EXPR_CONSTANT)
710 {
711 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
712 {
713 e2_op1 = gfc_discard_nops (e2->value.op.op1);
714 e2_op2 = gfc_discard_nops (e2->value.op.op2);
715
716 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
717 if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
718 {
719 mpz_sub (*result, e1_op1->value.integer,
720 e2_op1->value.integer);
721 return true;
722 }
723 }
724
725 }
726 }
727
728 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
729 {
730 e2_op1 = gfc_discard_nops (e2->value.op.op1);
731 e2_op2 = gfc_discard_nops (e2->value.op.op2);
732
733 /* Case 15: X - (X + c2) = -c2. */
734 if (e2_op2->expr_type == EXPR_CONSTANT
735 && gfc_dep_compare_expr (e1, e2_op1) == 0)
736 {
737 mpz_neg (*result, e2_op2->value.integer);
738 return true;
739 }
740 /* Case 16: X - (c2 + X) = -c2. */
741 if (e2_op1->expr_type == EXPR_CONSTANT
742 && gfc_dep_compare_expr (e1, e2_op2) == 0)
743 {
744 mpz_neg (*result, e2_op1->value.integer);
745 return true;
746 }
747 }
748
749 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
750 {
751 e2_op1 = gfc_discard_nops (e2->value.op.op1);
752 e2_op2 = gfc_discard_nops (e2->value.op.op2);
753
754 /* Case 17: X - (X - c2) = c2. */
755 if (e2_op2->expr_type == EXPR_CONSTANT
756 && gfc_dep_compare_expr (e1, e2_op1) == 0)
757 {
758 mpz_set (*result, e2_op2->value.integer);
759 return true;
760 }
761 }
762
763 if (gfc_dep_compare_expr (e1, e2) == 0)
764 {
765 /* Case 18: X - X = 0. */
766 mpz_set_si (*result, 0);
767 return true;
768 }
769
770 mpz_clear (*result);
771 return false;
772 }
773
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. */
776
777 static int
778 is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
779 {
780 gfc_expr *e1;
781 gfc_expr *e2;
782 int i;
783
784 /* TODO: More sophisticated range comparison. */
785 gcc_assert (ar1 && ar2);
786
787 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
788
789 e1 = ar1->stride[n];
790 e2 = ar2->stride[n];
791 /* Check for mismatching strides. A NULL stride means a stride of 1. */
792 if (e1 && !e2)
793 {
794 i = gfc_expr_is_one (e1, -1);
795 if (i == -1 || i == 0)
796 return 0;
797 }
798 else if (e2 && !e1)
799 {
800 i = gfc_expr_is_one (e2, -1);
801 if (i == -1 || i == 0)
802 return 0;
803 }
804 else if (e1 && e2)
805 {
806 i = gfc_dep_compare_expr (e1, e2);
807 if (i != 0)
808 return 0;
809 }
810 /* The strides match. */
811
812 /* Check the range start. */
813 e1 = ar1->start[n];
814 e2 = ar2->start[n];
815 if (e1 || e2)
816 {
817 /* Use the bound of the array if no bound is specified. */
818 if (ar1->as && !e1)
819 e1 = ar1->as->lower[n];
820
821 if (ar2->as && !e2)
822 e2 = ar2->as->lower[n];
823
824 /* Check we have values for both. */
825 if (!(e1 && e2))
826 return 0;
827
828 i = gfc_dep_compare_expr (e1, e2);
829 if (i != 0)
830 return 0;
831 }
832
833 /* Check the range end. */
834 e1 = ar1->end[n];
835 e2 = ar2->end[n];
836 if (e1 || e2)
837 {
838 /* Use the bound of the array if no bound is specified. */
839 if (ar1->as && !e1)
840 e1 = ar1->as->upper[n];
841
842 if (ar2->as && !e2)
843 e2 = ar2->as->upper[n];
844
845 /* Check we have values for both. */
846 if (!(e1 && e2))
847 return 0;
848
849 i = gfc_dep_compare_expr (e1, e2);
850 if (i != 0)
851 return 0;
852 }
853
854 return 1;
855 }
856
857
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.
863
864 If EXPR is a call to such an intrinsic, return the argument
865 whose data can be reused, otherwise return NULL. */
866
867 gfc_expr *
868 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
869 {
870 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
871 return NULL;
872
873 switch (expr->value.function.isym->id)
874 {
875 case GFC_ISYM_TRANSPOSE:
876 return expr->value.function.actual->expr;
877
878 default:
879 return NULL;
880 }
881 }
882
883
884 /* Return true if the result of reference REF can only be constructed
885 using a temporary array. */
886
887 bool
888 gfc_ref_needs_temporary_p (gfc_ref *ref)
889 {
890 int n;
891 bool subarray_p;
892
893 subarray_p = false;
894 for (; ref; ref = ref->next)
895 switch (ref->type)
896 {
897 case REF_ARRAY:
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)
903 return true;
904
905 subarray_p = true;
906 break;
907
908 case REF_SUBSTRING:
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. */
913 return subarray_p;
914
915 case REF_COMPONENT:
916 case REF_INQUIRY:
917 break;
918 }
919
920 return false;
921 }
922
923
924 static int
925 gfc_is_data_pointer (gfc_expr *e)
926 {
927 gfc_ref *ref;
928
929 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
930 return 0;
931
932 /* No subreference if it is a function */
933 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
934
935 if (e->symtree->n.sym->attr.pointer)
936 return 1;
937
938 for (ref = e->ref; ref; ref = ref->next)
939 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
940 return 1;
941
942 return 0;
943 }
944
945
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
948 of VAR.
949
950 This is considerably less conservative than other dependencies
951 because many function arguments will already be copied into a
952 temporary. */
953
954 static int
955 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
956 gfc_expr *expr, gfc_dep_check elemental)
957 {
958 gfc_expr *arg;
959
960 gcc_assert (var->expr_type == EXPR_VARIABLE);
961 gcc_assert (var->rank > 0);
962
963 switch (expr->expr_type)
964 {
965 case EXPR_VARIABLE:
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))
970 {
971 if (elemental == ELEM_DONT_CHECK_VARIABLE)
972 {
973 /* Too many false positive with pointers. */
974 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
975 {
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);
979
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. */
985
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);
993 }
994 return 0;
995 }
996 else
997 return 1;
998 }
999 return 0;
1000
1001 case EXPR_ARRAY:
1002 /* the scalarizer always generates a temporary for array constructors,
1003 so there is no dependency. */
1004 return 0;
1005
1006 case EXPR_FUNCTION:
1007 if (intent != INTENT_IN)
1008 {
1009 arg = gfc_get_noncopying_intrinsic_argument (expr);
1010 if (arg != NULL)
1011 return gfc_check_argument_var_dependency (var, intent, arg,
1012 NOT_ELEMENTAL);
1013 }
1014
1015 if (elemental != NOT_ELEMENTAL)
1016 {
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);
1024
1025 if (gfc_inline_intrinsic_function_p (expr))
1026 {
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);
1030
1031 return gfc_check_fncall_dependency (var, intent, NULL,
1032 expr->value.function.actual,
1033 ELEM_CHECK_VARIABLE);
1034 }
1035 }
1036 return 0;
1037
1038 case EXPR_OP:
1039 /* In case of non-elemental procedures, there is no need to catch
1040 dependencies, as we will make a temporary anyway. */
1041 if (elemental)
1042 {
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,
1048 expr->value.op.op1,
1049 ELEM_CHECK_VARIABLE))
1050 return 1;
1051 else if (expr->value.op.op2
1052 && gfc_check_argument_var_dependency (var, intent,
1053 expr->value.op.op2,
1054 ELEM_CHECK_VARIABLE))
1055 return 1;
1056 }
1057 return 0;
1058
1059 default:
1060 return 0;
1061 }
1062 }
1063
1064
1065 /* Like gfc_check_argument_var_dependency, but extended to any
1066 array expression OTHER, not just variables. */
1067
1068 static int
1069 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
1070 gfc_expr *expr, gfc_dep_check elemental)
1071 {
1072 switch (other->expr_type)
1073 {
1074 case EXPR_VARIABLE:
1075 return gfc_check_argument_var_dependency (other, intent, expr, elemental);
1076
1077 case EXPR_FUNCTION:
1078 other = gfc_get_noncopying_intrinsic_argument (other);
1079 if (other != NULL)
1080 return gfc_check_argument_dependency (other, INTENT_IN, expr,
1081 NOT_ELEMENTAL);
1082
1083 return 0;
1084
1085 default:
1086 return 0;
1087 }
1088 }
1089
1090
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. */
1093
1094 int
1095 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
1096 gfc_symbol *fnsym, gfc_actual_arglist *actual,
1097 gfc_dep_check elemental)
1098 {
1099 gfc_formal_arglist *formal;
1100 gfc_expr *expr;
1101
1102 formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
1103 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
1104 {
1105 expr = actual->expr;
1106
1107 /* Skip args which are not present. */
1108 if (!expr)
1109 continue;
1110
1111 /* Skip other itself. */
1112 if (expr == other)
1113 continue;
1114
1115 /* Skip intent(in) arguments if OTHER itself is intent(in). */
1116 if (formal && intent == INTENT_IN
1117 && formal->sym->attr.intent == INTENT_IN)
1118 continue;
1119
1120 if (gfc_check_argument_dependency (other, intent, expr, elemental))
1121 return 1;
1122 }
1123
1124 return 0;
1125 }
1126
1127
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. */
1139
1140 int
1141 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
1142 {
1143 gfc_equiv_list *l;
1144 gfc_equiv_info *s, *fl1, *fl2;
1145
1146 gcc_assert (e1->expr_type == EXPR_VARIABLE
1147 && e2->expr_type == EXPR_VARIABLE);
1148
1149 if (!e1->symtree->n.sym->attr.in_equivalence
1150 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
1151 return 0;
1152
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;
1156 else
1157 l = gfc_current_ns->equiv_lists;
1158
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)
1163 {
1164 fl1 = NULL;
1165 fl2 = NULL;
1166 for (s = l->equiv; s; s = s->next)
1167 {
1168 if (s->sym == e1->symtree->n.sym)
1169 {
1170 fl1 = s;
1171 if (fl2)
1172 break;
1173 }
1174 if (s->sym == e2->symtree->n.sym)
1175 {
1176 fl2 = s;
1177 if (fl1)
1178 break;
1179 }
1180 }
1181
1182 if (s)
1183 {
1184 /* Can these lengths be zero? */
1185 if (fl1->length <= 0 || fl2->length <= 0)
1186 return 1;
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)
1192 return 1;
1193 }
1194 }
1195 return 0;
1196 }
1197
1198
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. */
1203
1204 static bool
1205 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
1206 {
1207 gfc_component *cm1;
1208 gfc_symbol *sym1;
1209 gfc_symbol *sym2;
1210 gfc_ref *ref1;
1211 bool seen_component_ref;
1212
1213 if (expr1->expr_type != EXPR_VARIABLE
1214 || expr2->expr_type != EXPR_VARIABLE)
1215 return false;
1216
1217 sym1 = expr1->symtree->n.sym;
1218 sym2 = expr2->symtree->n.sym;
1219
1220 /* Keep it simple for now. */
1221 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
1222 return false;
1223
1224 if (sym1->attr.pointer)
1225 {
1226 if (gfc_compare_types (&sym1->ts, &sym2->ts))
1227 return false;
1228 }
1229
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)
1237 {
1238 for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
1239 {
1240 if (ref1->type != REF_COMPONENT)
1241 continue;
1242
1243 if (ref1->u.c.component->ts.type == BT_DERIVED)
1244 return false;
1245
1246 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
1247 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
1248 return false;
1249
1250 seen_component_ref = true;
1251 }
1252 }
1253
1254 if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
1255 {
1256 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
1257 {
1258 if (cm1->ts.type == BT_DERIVED)
1259 return false;
1260
1261 if ((sym2->attr.pointer || cm1->attr.pointer)
1262 && gfc_compare_types (&cm1->ts, &sym2->ts))
1263 return false;
1264 }
1265 }
1266
1267 return true;
1268 }
1269
1270
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
1277 temporary. */
1278
1279 int
1280 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1281 {
1282 gfc_actual_arglist *actual;
1283 gfc_constructor *c;
1284 int n;
1285
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)
1290 return 0;
1291
1292 if (expr1->expr_type != EXPR_VARIABLE)
1293 gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1294
1295 switch (expr2->expr_type)
1296 {
1297 case EXPR_OP:
1298 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1299 if (n)
1300 return n;
1301 if (expr2->value.op.op2)
1302 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1303 return 0;
1304
1305 case EXPR_VARIABLE:
1306 /* The interesting cases are when the symbols don't match. */
1307 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1308 {
1309 symbol_attribute attr1, attr2;
1310 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1311 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1312
1313 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1314 if (gfc_are_equivalenced_arrays (expr1, expr2))
1315 return 1;
1316
1317 /* Symbols can only alias if they have the same type. */
1318 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1319 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1320 {
1321 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1322 return 0;
1323 }
1324
1325 /* We have to also include target-target as ptr%comp is not a
1326 pointer but it still alias with "dt%comp" for "ptr => dt". As
1327 subcomponents and array access to pointers retains the target
1328 attribute, that's sufficient. */
1329 attr1 = gfc_expr_attr (expr1);
1330 attr2 = gfc_expr_attr (expr2);
1331 if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1332 {
1333 if (check_data_pointer_types (expr1, expr2)
1334 && check_data_pointer_types (expr2, expr1))
1335 return 0;
1336
1337 return 1;
1338 }
1339 else
1340 {
1341 gfc_symbol *sym1 = expr1->symtree->n.sym;
1342 gfc_symbol *sym2 = expr2->symtree->n.sym;
1343 if (sym1->attr.target && sym2->attr.target
1344 && ((sym1->attr.dummy && !sym1->attr.contiguous
1345 && (!sym1->attr.dimension
1346 || sym2->as->type == AS_ASSUMED_SHAPE))
1347 || (sym2->attr.dummy && !sym2->attr.contiguous
1348 && (!sym2->attr.dimension
1349 || sym2->as->type == AS_ASSUMED_SHAPE))))
1350 return 1;
1351 }
1352
1353 /* Otherwise distinct symbols have no dependencies. */
1354 return 0;
1355 }
1356
1357 /* Identical and disjoint ranges return 0,
1358 overlapping ranges return 1. */
1359 if (expr1->ref && expr2->ref)
1360 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
1361
1362 return 1;
1363
1364 case EXPR_FUNCTION:
1365 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1366 identical = 1;
1367
1368 /* Remember possible differences between elemental and
1369 transformational functions. All functions inside a FORALL
1370 will be pure. */
1371 for (actual = expr2->value.function.actual;
1372 actual; actual = actual->next)
1373 {
1374 if (!actual->expr)
1375 continue;
1376 n = gfc_check_dependency (expr1, actual->expr, identical);
1377 if (n)
1378 return n;
1379 }
1380 return 0;
1381
1382 case EXPR_CONSTANT:
1383 case EXPR_NULL:
1384 return 0;
1385
1386 case EXPR_ARRAY:
1387 /* Loop through the array constructor's elements. */
1388 for (c = gfc_constructor_first (expr2->value.constructor);
1389 c; c = gfc_constructor_next (c))
1390 {
1391 /* If this is an iterator, assume the worst. */
1392 if (c->iterator)
1393 return 1;
1394 /* Avoid recursion in the common case. */
1395 if (c->expr->expr_type == EXPR_CONSTANT)
1396 continue;
1397 if (gfc_check_dependency (expr1, c->expr, 1))
1398 return 1;
1399 }
1400 return 0;
1401
1402 default:
1403 return 1;
1404 }
1405 }
1406
1407
1408 /* Determines overlapping for two array sections. */
1409
1410 static gfc_dependency
1411 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1412 {
1413 gfc_expr *l_start;
1414 gfc_expr *l_end;
1415 gfc_expr *l_stride;
1416 gfc_expr *l_lower;
1417 gfc_expr *l_upper;
1418 int l_dir;
1419
1420 gfc_expr *r_start;
1421 gfc_expr *r_end;
1422 gfc_expr *r_stride;
1423 gfc_expr *r_lower;
1424 gfc_expr *r_upper;
1425 gfc_expr *one_expr;
1426 int r_dir;
1427 int stride_comparison;
1428 int start_comparison;
1429 mpz_t tmp;
1430
1431 /* If they are the same range, return without more ado. */
1432 if (is_same_range (l_ar, r_ar, n))
1433 return GFC_DEP_EQUAL;
1434
1435 l_start = l_ar->start[n];
1436 l_end = l_ar->end[n];
1437 l_stride = l_ar->stride[n];
1438
1439 r_start = r_ar->start[n];
1440 r_end = r_ar->end[n];
1441 r_stride = r_ar->stride[n];
1442
1443 /* If l_start is NULL take it from array specifier. */
1444 if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1445 l_start = l_ar->as->lower[n];
1446 /* If l_end is NULL take it from array specifier. */
1447 if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1448 l_end = l_ar->as->upper[n];
1449
1450 /* If r_start is NULL take it from array specifier. */
1451 if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1452 r_start = r_ar->as->lower[n];
1453 /* If r_end is NULL take it from array specifier. */
1454 if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1455 r_end = r_ar->as->upper[n];
1456
1457 /* Determine whether the l_stride is positive or negative. */
1458 if (!l_stride)
1459 l_dir = 1;
1460 else if (l_stride->expr_type == EXPR_CONSTANT
1461 && l_stride->ts.type == BT_INTEGER)
1462 l_dir = mpz_sgn (l_stride->value.integer);
1463 else if (l_start && l_end)
1464 l_dir = gfc_dep_compare_expr (l_end, l_start);
1465 else
1466 l_dir = -2;
1467
1468 /* Determine whether the r_stride is positive or negative. */
1469 if (!r_stride)
1470 r_dir = 1;
1471 else if (r_stride->expr_type == EXPR_CONSTANT
1472 && r_stride->ts.type == BT_INTEGER)
1473 r_dir = mpz_sgn (r_stride->value.integer);
1474 else if (r_start && r_end)
1475 r_dir = gfc_dep_compare_expr (r_end, r_start);
1476 else
1477 r_dir = -2;
1478
1479 /* The strides should never be zero. */
1480 if (l_dir == 0 || r_dir == 0)
1481 return GFC_DEP_OVERLAP;
1482
1483 /* Determine the relationship between the strides. Set stride_comparison to
1484 -2 if the dependency cannot be determined
1485 -1 if l_stride < r_stride
1486 0 if l_stride == r_stride
1487 1 if l_stride > r_stride
1488 as determined by gfc_dep_compare_expr. */
1489
1490 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1491
1492 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1493 r_stride ? r_stride : one_expr);
1494
1495 if (l_start && r_start)
1496 start_comparison = gfc_dep_compare_expr (l_start, r_start);
1497 else
1498 start_comparison = -2;
1499
1500 gfc_free_expr (one_expr);
1501
1502 /* Determine LHS upper and lower bounds. */
1503 if (l_dir == 1)
1504 {
1505 l_lower = l_start;
1506 l_upper = l_end;
1507 }
1508 else if (l_dir == -1)
1509 {
1510 l_lower = l_end;
1511 l_upper = l_start;
1512 }
1513 else
1514 {
1515 l_lower = NULL;
1516 l_upper = NULL;
1517 }
1518
1519 /* Determine RHS upper and lower bounds. */
1520 if (r_dir == 1)
1521 {
1522 r_lower = r_start;
1523 r_upper = r_end;
1524 }
1525 else if (r_dir == -1)
1526 {
1527 r_lower = r_end;
1528 r_upper = r_start;
1529 }
1530 else
1531 {
1532 r_lower = NULL;
1533 r_upper = NULL;
1534 }
1535
1536 /* Check whether the ranges are disjoint. */
1537 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1538 return GFC_DEP_NODEP;
1539 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1540 return GFC_DEP_NODEP;
1541
1542 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1543 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1544 {
1545 if (l_dir == 1 && r_dir == -1)
1546 return GFC_DEP_EQUAL;
1547 if (l_dir == -1 && r_dir == 1)
1548 return GFC_DEP_EQUAL;
1549 }
1550
1551 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1552 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1553 {
1554 if (l_dir == 1 && r_dir == -1)
1555 return GFC_DEP_EQUAL;
1556 if (l_dir == -1 && r_dir == 1)
1557 return GFC_DEP_EQUAL;
1558 }
1559
1560 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1561 There is no dependency if the remainder of
1562 (l_start - r_start) / gcd(l_stride, r_stride) is
1563 nonzero.
1564 TODO:
1565 - Cases like a(1:4:2) = a(2:3) are still not handled.
1566 */
1567
1568 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1569 && (a)->ts.type == BT_INTEGER)
1570
1571 if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1572 && gfc_dep_difference (l_start, r_start, &tmp))
1573 {
1574 mpz_t gcd;
1575 int result;
1576
1577 mpz_init (gcd);
1578 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1579
1580 mpz_fdiv_r (tmp, tmp, gcd);
1581 result = mpz_cmp_si (tmp, 0L);
1582
1583 mpz_clear (gcd);
1584 mpz_clear (tmp);
1585
1586 if (result != 0)
1587 return GFC_DEP_NODEP;
1588 }
1589
1590 #undef IS_CONSTANT_INTEGER
1591
1592 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1593
1594 if (l_dir == 1 && r_dir == 1 &&
1595 (start_comparison == 0 || start_comparison == -1)
1596 && (stride_comparison == 0 || stride_comparison == -1))
1597 return GFC_DEP_FORWARD;
1598
1599 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1600 x:y:-1 vs. x:y:-2. */
1601 if (l_dir == -1 && r_dir == -1 &&
1602 (start_comparison == 0 || start_comparison == 1)
1603 && (stride_comparison == 0 || stride_comparison == 1))
1604 return GFC_DEP_FORWARD;
1605
1606 if (stride_comparison == 0 || stride_comparison == -1)
1607 {
1608 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1609 {
1610
1611 /* Check for a(low:y:s) vs. a(z:x:s) or
1612 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1613 of low, which is always at least a forward dependence. */
1614
1615 if (r_dir == 1
1616 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1617 return GFC_DEP_FORWARD;
1618 }
1619 }
1620
1621 if (stride_comparison == 0 || stride_comparison == 1)
1622 {
1623 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1624 {
1625
1626 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1627 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1628 of high, which is always at least a forward dependence. */
1629
1630 if (r_dir == -1
1631 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1632 return GFC_DEP_FORWARD;
1633 }
1634 }
1635
1636
1637 if (stride_comparison == 0)
1638 {
1639 /* From here, check for backwards dependencies. */
1640 /* x+1:y vs. x:z. */
1641 if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1642 return GFC_DEP_BACKWARD;
1643
1644 /* x-1:y:-1 vs. x:z:-1. */
1645 if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1646 return GFC_DEP_BACKWARD;
1647 }
1648
1649 return GFC_DEP_OVERLAP;
1650 }
1651
1652
1653 /* Determines overlapping for a single element and a section. */
1654
1655 static gfc_dependency
1656 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1657 {
1658 gfc_array_ref *ref;
1659 gfc_expr *elem;
1660 gfc_expr *start;
1661 gfc_expr *end;
1662 gfc_expr *stride;
1663 int s;
1664
1665 elem = lref->u.ar.start[n];
1666 if (!elem)
1667 return GFC_DEP_OVERLAP;
1668
1669 ref = &rref->u.ar;
1670 start = ref->start[n] ;
1671 end = ref->end[n] ;
1672 stride = ref->stride[n];
1673
1674 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1675 start = ref->as->lower[n];
1676 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1677 end = ref->as->upper[n];
1678
1679 /* Determine whether the stride is positive or negative. */
1680 if (!stride)
1681 s = 1;
1682 else if (stride->expr_type == EXPR_CONSTANT
1683 && stride->ts.type == BT_INTEGER)
1684 s = mpz_sgn (stride->value.integer);
1685 else
1686 s = -2;
1687
1688 /* Stride should never be zero. */
1689 if (s == 0)
1690 return GFC_DEP_OVERLAP;
1691
1692 /* Positive strides. */
1693 if (s == 1)
1694 {
1695 /* Check for elem < lower. */
1696 if (start && gfc_dep_compare_expr (elem, start) == -1)
1697 return GFC_DEP_NODEP;
1698 /* Check for elem > upper. */
1699 if (end && gfc_dep_compare_expr (elem, end) == 1)
1700 return GFC_DEP_NODEP;
1701
1702 if (start && end)
1703 {
1704 s = gfc_dep_compare_expr (start, end);
1705 /* Check for an empty range. */
1706 if (s == 1)
1707 return GFC_DEP_NODEP;
1708 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1709 return GFC_DEP_EQUAL;
1710 }
1711 }
1712 /* Negative strides. */
1713 else if (s == -1)
1714 {
1715 /* Check for elem > upper. */
1716 if (end && gfc_dep_compare_expr (elem, start) == 1)
1717 return GFC_DEP_NODEP;
1718 /* Check for elem < lower. */
1719 if (start && gfc_dep_compare_expr (elem, end) == -1)
1720 return GFC_DEP_NODEP;
1721
1722 if (start && end)
1723 {
1724 s = gfc_dep_compare_expr (start, end);
1725 /* Check for an empty range. */
1726 if (s == -1)
1727 return GFC_DEP_NODEP;
1728 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1729 return GFC_DEP_EQUAL;
1730 }
1731 }
1732 /* Unknown strides. */
1733 else
1734 {
1735 if (!start || !end)
1736 return GFC_DEP_OVERLAP;
1737 s = gfc_dep_compare_expr (start, end);
1738 if (s <= -2)
1739 return GFC_DEP_OVERLAP;
1740 /* Assume positive stride. */
1741 if (s == -1)
1742 {
1743 /* Check for elem < lower. */
1744 if (gfc_dep_compare_expr (elem, start) == -1)
1745 return GFC_DEP_NODEP;
1746 /* Check for elem > upper. */
1747 if (gfc_dep_compare_expr (elem, end) == 1)
1748 return GFC_DEP_NODEP;
1749 }
1750 /* Assume negative stride. */
1751 else if (s == 1)
1752 {
1753 /* Check for elem > upper. */
1754 if (gfc_dep_compare_expr (elem, start) == 1)
1755 return GFC_DEP_NODEP;
1756 /* Check for elem < lower. */
1757 if (gfc_dep_compare_expr (elem, end) == -1)
1758 return GFC_DEP_NODEP;
1759 }
1760 /* Equal bounds. */
1761 else if (s == 0)
1762 {
1763 s = gfc_dep_compare_expr (elem, start);
1764 if (s == 0)
1765 return GFC_DEP_EQUAL;
1766 if (s == 1 || s == -1)
1767 return GFC_DEP_NODEP;
1768 }
1769 }
1770
1771 return GFC_DEP_OVERLAP;
1772 }
1773
1774
1775 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1776 forall_index attribute. Return true if any variable may be
1777 being used as a FORALL index. Its safe to pessimistically
1778 return true, and assume a dependency. */
1779
1780 static bool
1781 contains_forall_index_p (gfc_expr *expr)
1782 {
1783 gfc_actual_arglist *arg;
1784 gfc_constructor *c;
1785 gfc_ref *ref;
1786 int i;
1787
1788 if (!expr)
1789 return false;
1790
1791 switch (expr->expr_type)
1792 {
1793 case EXPR_VARIABLE:
1794 if (expr->symtree->n.sym->forall_index)
1795 return true;
1796 break;
1797
1798 case EXPR_OP:
1799 if (contains_forall_index_p (expr->value.op.op1)
1800 || contains_forall_index_p (expr->value.op.op2))
1801 return true;
1802 break;
1803
1804 case EXPR_FUNCTION:
1805 for (arg = expr->value.function.actual; arg; arg = arg->next)
1806 if (contains_forall_index_p (arg->expr))
1807 return true;
1808 break;
1809
1810 case EXPR_CONSTANT:
1811 case EXPR_NULL:
1812 case EXPR_SUBSTRING:
1813 break;
1814
1815 case EXPR_STRUCTURE:
1816 case EXPR_ARRAY:
1817 for (c = gfc_constructor_first (expr->value.constructor);
1818 c; gfc_constructor_next (c))
1819 if (contains_forall_index_p (c->expr))
1820 return true;
1821 break;
1822
1823 default:
1824 gcc_unreachable ();
1825 }
1826
1827 for (ref = expr->ref; ref; ref = ref->next)
1828 switch (ref->type)
1829 {
1830 case REF_ARRAY:
1831 for (i = 0; i < ref->u.ar.dimen; i++)
1832 if (contains_forall_index_p (ref->u.ar.start[i])
1833 || contains_forall_index_p (ref->u.ar.end[i])
1834 || contains_forall_index_p (ref->u.ar.stride[i]))
1835 return true;
1836 break;
1837
1838 case REF_COMPONENT:
1839 break;
1840
1841 case REF_SUBSTRING:
1842 if (contains_forall_index_p (ref->u.ss.start)
1843 || contains_forall_index_p (ref->u.ss.end))
1844 return true;
1845 break;
1846
1847 default:
1848 gcc_unreachable ();
1849 }
1850
1851 return false;
1852 }
1853
1854 /* Determines overlapping for two single element array references. */
1855
1856 static gfc_dependency
1857 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1858 {
1859 gfc_array_ref l_ar;
1860 gfc_array_ref r_ar;
1861 gfc_expr *l_start;
1862 gfc_expr *r_start;
1863 int i;
1864
1865 l_ar = lref->u.ar;
1866 r_ar = rref->u.ar;
1867 l_start = l_ar.start[n] ;
1868 r_start = r_ar.start[n] ;
1869 i = gfc_dep_compare_expr (r_start, l_start);
1870 if (i == 0)
1871 return GFC_DEP_EQUAL;
1872
1873 /* Treat two scalar variables as potentially equal. This allows
1874 us to prove that a(i,:) and a(j,:) have no dependency. See
1875 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1876 Proceedings of the International Conference on Parallel and
1877 Distributed Processing Techniques and Applications (PDPTA2001),
1878 Las Vegas, Nevada, June 2001. */
1879 /* However, we need to be careful when either scalar expression
1880 contains a FORALL index, as these can potentially change value
1881 during the scalarization/traversal of this array reference. */
1882 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1883 return GFC_DEP_OVERLAP;
1884
1885 if (i > -2)
1886 return GFC_DEP_NODEP;
1887
1888 return GFC_DEP_EQUAL;
1889 }
1890
1891 /* Callback function for checking if an expression depends on a
1892 dummy variable which is any other than INTENT(IN). */
1893
1894 static int
1895 callback_dummy_intent_not_in (gfc_expr **ep,
1896 int *walk_subtrees ATTRIBUTE_UNUSED,
1897 void *data ATTRIBUTE_UNUSED)
1898 {
1899 gfc_expr *e = *ep;
1900
1901 if (e->expr_type == EXPR_VARIABLE && e->symtree
1902 && e->symtree->n.sym->attr.dummy)
1903 return e->symtree->n.sym->attr.intent != INTENT_IN;
1904 else
1905 return 0;
1906 }
1907
1908 /* Auxiliary function to check if subexpressions have dummy variables which
1909 are not intent(in).
1910 */
1911
1912 static bool
1913 dummy_intent_not_in (gfc_expr **ep)
1914 {
1915 return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
1916 }
1917
1918 /* Determine if an array ref, usually an array section specifies the
1919 entire array. In addition, if the second, pointer argument is
1920 provided, the function will return true if the reference is
1921 contiguous; eg. (:, 1) gives true but (1,:) gives false.
1922 If one of the bounds depends on a dummy variable which is
1923 not INTENT(IN), also return false, because the user may
1924 have changed the variable. */
1925
1926 bool
1927 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1928 {
1929 int i;
1930 int n;
1931 bool lbound_OK = true;
1932 bool ubound_OK = true;
1933
1934 if (contiguous)
1935 *contiguous = false;
1936
1937 if (ref->type != REF_ARRAY)
1938 return false;
1939
1940 if (ref->u.ar.type == AR_FULL)
1941 {
1942 if (contiguous)
1943 *contiguous = true;
1944 return true;
1945 }
1946
1947 if (ref->u.ar.type != AR_SECTION)
1948 return false;
1949 if (ref->next)
1950 return false;
1951
1952 for (i = 0; i < ref->u.ar.dimen; i++)
1953 {
1954 /* If we have a single element in the reference, for the reference
1955 to be full, we need to ascertain that the array has a single
1956 element in this dimension and that we actually reference the
1957 correct element. */
1958 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1959 {
1960 /* This is unconditionally a contiguous reference if all the
1961 remaining dimensions are elements. */
1962 if (contiguous)
1963 {
1964 *contiguous = true;
1965 for (n = i + 1; n < ref->u.ar.dimen; n++)
1966 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1967 *contiguous = false;
1968 }
1969
1970 if (!ref->u.ar.as
1971 || !ref->u.ar.as->lower[i]
1972 || !ref->u.ar.as->upper[i]
1973 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1974 ref->u.ar.as->upper[i])
1975 || !ref->u.ar.start[i]
1976 || gfc_dep_compare_expr (ref->u.ar.start[i],
1977 ref->u.ar.as->lower[i]))
1978 return false;
1979 else
1980 continue;
1981 }
1982
1983 /* Check the lower bound. */
1984 if (ref->u.ar.start[i]
1985 && (!ref->u.ar.as
1986 || !ref->u.ar.as->lower[i]
1987 || gfc_dep_compare_expr (ref->u.ar.start[i],
1988 ref->u.ar.as->lower[i])
1989 || dummy_intent_not_in (&ref->u.ar.start[i])))
1990 lbound_OK = false;
1991 /* Check the upper bound. */
1992 if (ref->u.ar.end[i]
1993 && (!ref->u.ar.as
1994 || !ref->u.ar.as->upper[i]
1995 || gfc_dep_compare_expr (ref->u.ar.end[i],
1996 ref->u.ar.as->upper[i])
1997 || dummy_intent_not_in (&ref->u.ar.end[i])))
1998 ubound_OK = false;
1999 /* Check the stride. */
2000 if (ref->u.ar.stride[i]
2001 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2002 return false;
2003
2004 /* This is unconditionally a contiguous reference as long as all
2005 the subsequent dimensions are elements. */
2006 if (contiguous)
2007 {
2008 *contiguous = true;
2009 for (n = i + 1; n < ref->u.ar.dimen; n++)
2010 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2011 *contiguous = false;
2012 }
2013
2014 if (!lbound_OK || !ubound_OK)
2015 return false;
2016 }
2017 return true;
2018 }
2019
2020
2021 /* Determine if a full array is the same as an array section with one
2022 variable limit. For this to be so, the strides must both be unity
2023 and one of either start == lower or end == upper must be true. */
2024
2025 static bool
2026 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2027 {
2028 int i;
2029 bool upper_or_lower;
2030
2031 if (full_ref->type != REF_ARRAY)
2032 return false;
2033 if (full_ref->u.ar.type != AR_FULL)
2034 return false;
2035 if (ref->type != REF_ARRAY)
2036 return false;
2037 if (ref->u.ar.type == AR_FULL)
2038 return true;
2039 if (ref->u.ar.type != AR_SECTION)
2040 return false;
2041
2042 for (i = 0; i < ref->u.ar.dimen; i++)
2043 {
2044 /* If we have a single element in the reference, we need to check
2045 that the array has a single element and that we actually reference
2046 the correct element. */
2047 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2048 {
2049 if (!full_ref->u.ar.as
2050 || !full_ref->u.ar.as->lower[i]
2051 || !full_ref->u.ar.as->upper[i]
2052 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
2053 full_ref->u.ar.as->upper[i])
2054 || !ref->u.ar.start[i]
2055 || gfc_dep_compare_expr (ref->u.ar.start[i],
2056 full_ref->u.ar.as->lower[i]))
2057 return false;
2058 }
2059
2060 /* Check the strides. */
2061 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
2062 return false;
2063 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2064 return false;
2065
2066 upper_or_lower = false;
2067 /* Check the lower bound. */
2068 if (ref->u.ar.start[i]
2069 && (ref->u.ar.as
2070 && full_ref->u.ar.as->lower[i]
2071 && gfc_dep_compare_expr (ref->u.ar.start[i],
2072 full_ref->u.ar.as->lower[i]) == 0))
2073 upper_or_lower = true;
2074 /* Check the upper bound. */
2075 if (ref->u.ar.end[i]
2076 && (ref->u.ar.as
2077 && full_ref->u.ar.as->upper[i]
2078 && gfc_dep_compare_expr (ref->u.ar.end[i],
2079 full_ref->u.ar.as->upper[i]) == 0))
2080 upper_or_lower = true;
2081 if (!upper_or_lower)
2082 return false;
2083 }
2084 return true;
2085 }
2086
2087
2088 /* Finds if two array references are overlapping or not.
2089 Return value
2090 2 : array references are overlapping but reversal of one or
2091 more dimensions will clear the dependency.
2092 1 : array references are overlapping, or identical is true and
2093 there is some kind of overlap.
2094 0 : array references are identical or not overlapping. */
2095
2096 int
2097 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
2098 bool identical)
2099 {
2100 int n;
2101 int m;
2102 gfc_dependency fin_dep;
2103 gfc_dependency this_dep;
2104 bool same_component = false;
2105
2106 this_dep = GFC_DEP_ERROR;
2107 fin_dep = GFC_DEP_ERROR;
2108 /* Dependencies due to pointers should already have been identified.
2109 We only need to check for overlapping array references. */
2110
2111 while (lref && rref)
2112 {
2113 /* The refs might come in mixed, one with a _data component and one
2114 without. Look at their next reference in order to avoid an
2115 ICE. */
2116
2117 if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2118 && strcmp (lref->u.c.component->name, "_data") == 0)
2119 lref = lref->next;
2120
2121 if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2122 && strcmp (rref->u.c.component->name, "_data") == 0)
2123 rref = rref->next;
2124
2125 /* We're resolving from the same base symbol, so both refs should be
2126 the same type. We traverse the reference chain until we find ranges
2127 that are not equal. */
2128 gcc_assert (lref->type == rref->type);
2129 switch (lref->type)
2130 {
2131 case REF_COMPONENT:
2132 /* The two ranges can't overlap if they are from different
2133 components. */
2134 if (lref->u.c.component != rref->u.c.component)
2135 return 0;
2136
2137 same_component = true;
2138 break;
2139
2140 case REF_SUBSTRING:
2141 /* Substring overlaps are handled by the string assignment code
2142 if there is not an underlying dependency. */
2143 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2144
2145 case REF_ARRAY:
2146 /* Coarrays: If there is a coindex, either the image differs and there
2147 is no overlap or the image is the same - then the normal analysis
2148 applies. Hence, return early if either ref is coindexed and more
2149 than one image can exist. */
2150 if (flag_coarray != GFC_FCOARRAY_SINGLE
2151 && ((lref->u.ar.codimen
2152 && lref->u.ar.dimen_type[lref->u.ar.dimen]
2153 != DIMEN_THIS_IMAGE)
2154 || (rref->u.ar.codimen
2155 && lref->u.ar.dimen_type[lref->u.ar.dimen]
2156 != DIMEN_THIS_IMAGE)))
2157 return 1;
2158 if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0)
2159 {
2160 /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */
2161 if (lref->u.ar.dimen || rref->u.ar.dimen)
2162 return 1; /* Just to be sure. */
2163 fin_dep = GFC_DEP_EQUAL;
2164 break;
2165 }
2166
2167 if (ref_same_as_full_array (lref, rref))
2168 return identical;
2169
2170 if (ref_same_as_full_array (rref, lref))
2171 return identical;
2172
2173 if (lref->u.ar.dimen != rref->u.ar.dimen)
2174 {
2175 if (lref->u.ar.type == AR_FULL)
2176 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
2177 : GFC_DEP_OVERLAP;
2178 else if (rref->u.ar.type == AR_FULL)
2179 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
2180 : GFC_DEP_OVERLAP;
2181 else
2182 return 1;
2183 break;
2184 }
2185
2186 /* Index for the reverse array. */
2187 m = -1;
2188 for (n = 0; n < lref->u.ar.dimen; n++)
2189 {
2190 /* Handle dependency when either of array reference is vector
2191 subscript. There is no dependency if the vector indices
2192 are equal or if indices are known to be different in a
2193 different dimension. */
2194 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2195 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2196 {
2197 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2198 && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2199 && gfc_dep_compare_expr (lref->u.ar.start[n],
2200 rref->u.ar.start[n]) == 0)
2201 this_dep = GFC_DEP_EQUAL;
2202 else
2203 this_dep = GFC_DEP_OVERLAP;
2204
2205 goto update_fin_dep;
2206 }
2207
2208 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2209 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2210 this_dep = check_section_vs_section (&lref->u.ar,
2211 &rref->u.ar, n);
2212 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2213 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2214 this_dep = gfc_check_element_vs_section (lref, rref, n);
2215 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2216 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2217 this_dep = gfc_check_element_vs_section (rref, lref, n);
2218 else
2219 {
2220 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2221 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2222 this_dep = gfc_check_element_vs_element (rref, lref, n);
2223 if (identical && this_dep == GFC_DEP_EQUAL)
2224 this_dep = GFC_DEP_OVERLAP;
2225 }
2226
2227 /* If any dimension doesn't overlap, we have no dependency. */
2228 if (this_dep == GFC_DEP_NODEP)
2229 return 0;
2230
2231 /* Now deal with the loop reversal logic: This only works on
2232 ranges and is activated by setting
2233 reverse[n] == GFC_ENABLE_REVERSE
2234 The ability to reverse or not is set by previous conditions
2235 in this dimension. If reversal is not activated, the
2236 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2237
2238 /* Get the indexing right for the scalarizing loop. If this
2239 is an element, there is no corresponding loop. */
2240 if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2241 m++;
2242
2243 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2244 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2245 {
2246 if (reverse)
2247 {
2248 /* Reverse if backward dependence and not inhibited. */
2249 if (reverse[m] == GFC_ENABLE_REVERSE
2250 && this_dep == GFC_DEP_BACKWARD)
2251 reverse[m] = GFC_REVERSE_SET;
2252
2253 /* Forward if forward dependence and not inhibited. */
2254 if (reverse[m] == GFC_ENABLE_REVERSE
2255 && this_dep == GFC_DEP_FORWARD)
2256 reverse[m] = GFC_FORWARD_SET;
2257
2258 /* Flag up overlap if dependence not compatible with
2259 the overall state of the expression. */
2260 if (reverse[m] == GFC_REVERSE_SET
2261 && this_dep == GFC_DEP_FORWARD)
2262 {
2263 reverse[m] = GFC_INHIBIT_REVERSE;
2264 this_dep = GFC_DEP_OVERLAP;
2265 }
2266 else if (reverse[m] == GFC_FORWARD_SET
2267 && this_dep == GFC_DEP_BACKWARD)
2268 {
2269 reverse[m] = GFC_INHIBIT_REVERSE;
2270 this_dep = GFC_DEP_OVERLAP;
2271 }
2272 }
2273
2274 /* If no intention of reversing or reversing is explicitly
2275 inhibited, convert backward dependence to overlap. */
2276 if ((!reverse && this_dep == GFC_DEP_BACKWARD)
2277 || (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
2278 this_dep = GFC_DEP_OVERLAP;
2279 }
2280
2281 /* Overlap codes are in order of priority. We only need to
2282 know the worst one.*/
2283
2284 update_fin_dep:
2285 if (identical && this_dep == GFC_DEP_EQUAL)
2286 this_dep = GFC_DEP_OVERLAP;
2287
2288 if (this_dep > fin_dep)
2289 fin_dep = this_dep;
2290 }
2291
2292 /* If this is an equal element, we have to keep going until we find
2293 the "real" array reference. */
2294 if (lref->u.ar.type == AR_ELEMENT
2295 && rref->u.ar.type == AR_ELEMENT
2296 && fin_dep == GFC_DEP_EQUAL)
2297 break;
2298
2299 /* Exactly matching and forward overlapping ranges don't cause a
2300 dependency. */
2301 if (fin_dep < GFC_DEP_BACKWARD && !identical)
2302 return 0;
2303
2304 /* Keep checking. We only have a dependency if
2305 subsequent references also overlap. */
2306 break;
2307
2308 case REF_INQUIRY:
2309 if (lref->u.i != rref->u.i)
2310 return 0;
2311
2312 break;
2313
2314 default:
2315 gcc_unreachable ();
2316 }
2317 lref = lref->next;
2318 rref = rref->next;
2319 }
2320
2321 /* Assume the worst if we nest to different depths. */
2322 if (lref || rref)
2323 return 1;
2324
2325 /* This can result from concatenation of assumed length string components. */
2326 if (same_component && fin_dep == GFC_DEP_ERROR)
2327 return 1;
2328
2329 /* If we haven't seen any array refs then something went wrong. */
2330 gcc_assert (fin_dep != GFC_DEP_ERROR);
2331
2332 if (identical && fin_dep != GFC_DEP_NODEP)
2333 return 1;
2334
2335 return fin_dep == GFC_DEP_OVERLAP;
2336 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org