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