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
gfc_expr_is_one(gfc_expr * expr,int def)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
identical_array_ref(gfc_array_ref * a1,gfc_array_ref * a2)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
are_identical_variables(gfc_expr * e1,gfc_expr * e2)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
gfc_dep_compare_functions(gfc_expr * e1,gfc_expr * e2,bool impure_ok)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 *
gfc_discard_nops(gfc_expr * e)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
gfc_dep_compare_expr(gfc_expr * e1,gfc_expr * e2)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
gfc_dep_difference(gfc_expr * e1,gfc_expr * e2,mpz_t * result)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
is_same_range(gfc_array_ref * ar1,gfc_array_ref * ar2,int n)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 *
gfc_get_noncopying_intrinsic_argument(gfc_expr * 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
gfc_ref_needs_temporary_p(gfc_ref * ref)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
gfc_is_data_pointer(gfc_expr * e)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
gfc_check_argument_var_dependency(gfc_expr * var,sym_intent intent,gfc_expr * expr,gfc_dep_check elemental)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
gfc_check_argument_dependency(gfc_expr * other,sym_intent intent,gfc_expr * expr,gfc_dep_check elemental)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
gfc_check_fncall_dependency(gfc_expr * other,sym_intent intent,gfc_symbol * fnsym,gfc_actual_arglist * actual,gfc_dep_check elemental)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
gfc_are_equivalenced_arrays(gfc_expr * e1,gfc_expr * e2)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
check_data_pointer_types(gfc_expr * expr1,gfc_expr * expr2)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
gfc_check_dependency(gfc_expr * expr1,gfc_expr * expr2,bool identical)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 /* Prevent NULL pointer dereference while recursively analyzing invalid
1295 expressions. */
1296 if (expr2 == NULL)
1297 return 0;
1298
1299 switch (expr2->expr_type)
1300 {
1301 case EXPR_OP:
1302 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1303 if (n)
1304 return n;
1305 if (expr2->value.op.op2)
1306 return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1307 return 0;
1308
1309 case EXPR_VARIABLE:
1310 /* The interesting cases are when the symbols don't match. */
1311 if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1312 {
1313 symbol_attribute attr1, attr2;
1314 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1315 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1316
1317 /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1318 if (gfc_are_equivalenced_arrays (expr1, expr2))
1319 return 1;
1320
1321 /* Symbols can only alias if they have the same type. */
1322 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1323 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1324 {
1325 if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1326 return 0;
1327 }
1328
1329 /* We have to also include target-target as ptr%comp is not a
1330 pointer but it still alias with "dt%comp" for "ptr => dt". As
1331 subcomponents and array access to pointers retains the target
1332 attribute, that's sufficient. */
1333 attr1 = gfc_expr_attr (expr1);
1334 attr2 = gfc_expr_attr (expr2);
1335 if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1336 {
1337 if (check_data_pointer_types (expr1, expr2)
1338 && check_data_pointer_types (expr2, expr1))
1339 return 0;
1340
1341 return 1;
1342 }
1343 else
1344 {
1345 gfc_symbol *sym1 = expr1->symtree->n.sym;
1346 gfc_symbol *sym2 = expr2->symtree->n.sym;
1347 if (sym1->attr.target && sym2->attr.target
1348 && ((sym1->attr.dummy && !sym1->attr.contiguous
1349 && (!sym1->attr.dimension
1350 || sym2->as->type == AS_ASSUMED_SHAPE))
1351 || (sym2->attr.dummy && !sym2->attr.contiguous
1352 && (!sym2->attr.dimension
1353 || sym2->as->type == AS_ASSUMED_SHAPE))))
1354 return 1;
1355 }
1356
1357 /* Otherwise distinct symbols have no dependencies. */
1358 return 0;
1359 }
1360
1361 /* Identical and disjoint ranges return 0,
1362 overlapping ranges return 1. */
1363 if (expr1->ref && expr2->ref)
1364 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
1365
1366 return 1;
1367
1368 case EXPR_FUNCTION:
1369 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1370 identical = 1;
1371
1372 /* Remember possible differences between elemental and
1373 transformational functions. All functions inside a FORALL
1374 will be pure. */
1375 for (actual = expr2->value.function.actual;
1376 actual; actual = actual->next)
1377 {
1378 if (!actual->expr)
1379 continue;
1380 n = gfc_check_dependency (expr1, actual->expr, identical);
1381 if (n)
1382 return n;
1383 }
1384 return 0;
1385
1386 case EXPR_CONSTANT:
1387 case EXPR_NULL:
1388 return 0;
1389
1390 case EXPR_ARRAY:
1391 /* Loop through the array constructor's elements. */
1392 for (c = gfc_constructor_first (expr2->value.constructor);
1393 c; c = gfc_constructor_next (c))
1394 {
1395 /* If this is an iterator, assume the worst. */
1396 if (c->iterator)
1397 return 1;
1398 /* Avoid recursion in the common case. */
1399 if (c->expr->expr_type == EXPR_CONSTANT)
1400 continue;
1401 if (gfc_check_dependency (expr1, c->expr, 1))
1402 return 1;
1403 }
1404 return 0;
1405
1406 default:
1407 return 1;
1408 }
1409 }
1410
1411
1412 /* Determines overlapping for two array sections. */
1413
1414 static gfc_dependency
check_section_vs_section(gfc_array_ref * l_ar,gfc_array_ref * r_ar,int n)1415 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1416 {
1417 gfc_expr *l_start;
1418 gfc_expr *l_end;
1419 gfc_expr *l_stride;
1420 gfc_expr *l_lower;
1421 gfc_expr *l_upper;
1422 int l_dir;
1423
1424 gfc_expr *r_start;
1425 gfc_expr *r_end;
1426 gfc_expr *r_stride;
1427 gfc_expr *r_lower;
1428 gfc_expr *r_upper;
1429 gfc_expr *one_expr;
1430 int r_dir;
1431 int stride_comparison;
1432 int start_comparison;
1433 mpz_t tmp;
1434
1435 /* If they are the same range, return without more ado. */
1436 if (is_same_range (l_ar, r_ar, n))
1437 return GFC_DEP_EQUAL;
1438
1439 l_start = l_ar->start[n];
1440 l_end = l_ar->end[n];
1441 l_stride = l_ar->stride[n];
1442
1443 r_start = r_ar->start[n];
1444 r_end = r_ar->end[n];
1445 r_stride = r_ar->stride[n];
1446
1447 /* If l_start is NULL take it from array specifier. */
1448 if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1449 l_start = l_ar->as->lower[n];
1450 /* If l_end is NULL take it from array specifier. */
1451 if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1452 l_end = l_ar->as->upper[n];
1453
1454 /* If r_start is NULL take it from array specifier. */
1455 if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1456 r_start = r_ar->as->lower[n];
1457 /* If r_end is NULL take it from array specifier. */
1458 if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1459 r_end = r_ar->as->upper[n];
1460
1461 /* Determine whether the l_stride is positive or negative. */
1462 if (!l_stride)
1463 l_dir = 1;
1464 else if (l_stride->expr_type == EXPR_CONSTANT
1465 && l_stride->ts.type == BT_INTEGER)
1466 l_dir = mpz_sgn (l_stride->value.integer);
1467 else if (l_start && l_end)
1468 l_dir = gfc_dep_compare_expr (l_end, l_start);
1469 else
1470 l_dir = -2;
1471
1472 /* Determine whether the r_stride is positive or negative. */
1473 if (!r_stride)
1474 r_dir = 1;
1475 else if (r_stride->expr_type == EXPR_CONSTANT
1476 && r_stride->ts.type == BT_INTEGER)
1477 r_dir = mpz_sgn (r_stride->value.integer);
1478 else if (r_start && r_end)
1479 r_dir = gfc_dep_compare_expr (r_end, r_start);
1480 else
1481 r_dir = -2;
1482
1483 /* The strides should never be zero. */
1484 if (l_dir == 0 || r_dir == 0)
1485 return GFC_DEP_OVERLAP;
1486
1487 /* Determine the relationship between the strides. Set stride_comparison to
1488 -2 if the dependency cannot be determined
1489 -1 if l_stride < r_stride
1490 0 if l_stride == r_stride
1491 1 if l_stride > r_stride
1492 as determined by gfc_dep_compare_expr. */
1493
1494 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1495
1496 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1497 r_stride ? r_stride : one_expr);
1498
1499 if (l_start && r_start)
1500 start_comparison = gfc_dep_compare_expr (l_start, r_start);
1501 else
1502 start_comparison = -2;
1503
1504 gfc_free_expr (one_expr);
1505
1506 /* Determine LHS upper and lower bounds. */
1507 if (l_dir == 1)
1508 {
1509 l_lower = l_start;
1510 l_upper = l_end;
1511 }
1512 else if (l_dir == -1)
1513 {
1514 l_lower = l_end;
1515 l_upper = l_start;
1516 }
1517 else
1518 {
1519 l_lower = NULL;
1520 l_upper = NULL;
1521 }
1522
1523 /* Determine RHS upper and lower bounds. */
1524 if (r_dir == 1)
1525 {
1526 r_lower = r_start;
1527 r_upper = r_end;
1528 }
1529 else if (r_dir == -1)
1530 {
1531 r_lower = r_end;
1532 r_upper = r_start;
1533 }
1534 else
1535 {
1536 r_lower = NULL;
1537 r_upper = NULL;
1538 }
1539
1540 /* Check whether the ranges are disjoint. */
1541 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1542 return GFC_DEP_NODEP;
1543 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1544 return GFC_DEP_NODEP;
1545
1546 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1547 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1548 {
1549 if (l_dir == 1 && r_dir == -1)
1550 return GFC_DEP_EQUAL;
1551 if (l_dir == -1 && r_dir == 1)
1552 return GFC_DEP_EQUAL;
1553 }
1554
1555 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1556 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1557 {
1558 if (l_dir == 1 && r_dir == -1)
1559 return GFC_DEP_EQUAL;
1560 if (l_dir == -1 && r_dir == 1)
1561 return GFC_DEP_EQUAL;
1562 }
1563
1564 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1565 There is no dependency if the remainder of
1566 (l_start - r_start) / gcd(l_stride, r_stride) is
1567 nonzero.
1568 TODO:
1569 - Cases like a(1:4:2) = a(2:3) are still not handled.
1570 */
1571
1572 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1573 && (a)->ts.type == BT_INTEGER)
1574
1575 if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1576 && gfc_dep_difference (l_start, r_start, &tmp))
1577 {
1578 mpz_t gcd;
1579 int result;
1580
1581 mpz_init (gcd);
1582 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1583
1584 mpz_fdiv_r (tmp, tmp, gcd);
1585 result = mpz_cmp_si (tmp, 0L);
1586
1587 mpz_clear (gcd);
1588 mpz_clear (tmp);
1589
1590 if (result != 0)
1591 return GFC_DEP_NODEP;
1592 }
1593
1594 #undef IS_CONSTANT_INTEGER
1595
1596 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1597
1598 if (l_dir == 1 && r_dir == 1 &&
1599 (start_comparison == 0 || start_comparison == -1)
1600 && (stride_comparison == 0 || stride_comparison == -1))
1601 return GFC_DEP_FORWARD;
1602
1603 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1604 x:y:-1 vs. x:y:-2. */
1605 if (l_dir == -1 && r_dir == -1 &&
1606 (start_comparison == 0 || start_comparison == 1)
1607 && (stride_comparison == 0 || stride_comparison == 1))
1608 return GFC_DEP_FORWARD;
1609
1610 if (stride_comparison == 0 || stride_comparison == -1)
1611 {
1612 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1613 {
1614
1615 /* Check for a(low:y:s) vs. a(z:x:s) or
1616 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1617 of low, which is always at least a forward dependence. */
1618
1619 if (r_dir == 1
1620 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1621 return GFC_DEP_FORWARD;
1622 }
1623 }
1624
1625 if (stride_comparison == 0 || stride_comparison == 1)
1626 {
1627 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1628 {
1629
1630 /* Check for a(high:y:-s) vs. a(z:x:-s) or
1631 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1632 of high, which is always at least a forward dependence. */
1633
1634 if (r_dir == -1
1635 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1636 return GFC_DEP_FORWARD;
1637 }
1638 }
1639
1640
1641 if (stride_comparison == 0)
1642 {
1643 /* From here, check for backwards dependencies. */
1644 /* x+1:y vs. x:z. */
1645 if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1646 return GFC_DEP_BACKWARD;
1647
1648 /* x-1:y:-1 vs. x:z:-1. */
1649 if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1650 return GFC_DEP_BACKWARD;
1651 }
1652
1653 return GFC_DEP_OVERLAP;
1654 }
1655
1656
1657 /* Determines overlapping for a single element and a section. */
1658
1659 static gfc_dependency
gfc_check_element_vs_section(gfc_ref * lref,gfc_ref * rref,int n)1660 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1661 {
1662 gfc_array_ref *ref;
1663 gfc_expr *elem;
1664 gfc_expr *start;
1665 gfc_expr *end;
1666 gfc_expr *stride;
1667 int s;
1668
1669 elem = lref->u.ar.start[n];
1670 if (!elem)
1671 return GFC_DEP_OVERLAP;
1672
1673 ref = &rref->u.ar;
1674 start = ref->start[n] ;
1675 end = ref->end[n] ;
1676 stride = ref->stride[n];
1677
1678 if (!start && IS_ARRAY_EXPLICIT (ref->as))
1679 start = ref->as->lower[n];
1680 if (!end && IS_ARRAY_EXPLICIT (ref->as))
1681 end = ref->as->upper[n];
1682
1683 /* Determine whether the stride is positive or negative. */
1684 if (!stride)
1685 s = 1;
1686 else if (stride->expr_type == EXPR_CONSTANT
1687 && stride->ts.type == BT_INTEGER)
1688 s = mpz_sgn (stride->value.integer);
1689 else
1690 s = -2;
1691
1692 /* Stride should never be zero. */
1693 if (s == 0)
1694 return GFC_DEP_OVERLAP;
1695
1696 /* Positive strides. */
1697 if (s == 1)
1698 {
1699 /* Check for elem < lower. */
1700 if (start && gfc_dep_compare_expr (elem, start) == -1)
1701 return GFC_DEP_NODEP;
1702 /* Check for elem > upper. */
1703 if (end && gfc_dep_compare_expr (elem, end) == 1)
1704 return GFC_DEP_NODEP;
1705
1706 if (start && end)
1707 {
1708 s = gfc_dep_compare_expr (start, end);
1709 /* Check for an empty range. */
1710 if (s == 1)
1711 return GFC_DEP_NODEP;
1712 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1713 return GFC_DEP_EQUAL;
1714 }
1715 }
1716 /* Negative strides. */
1717 else if (s == -1)
1718 {
1719 /* Check for elem > upper. */
1720 if (end && gfc_dep_compare_expr (elem, start) == 1)
1721 return GFC_DEP_NODEP;
1722 /* Check for elem < lower. */
1723 if (start && gfc_dep_compare_expr (elem, end) == -1)
1724 return GFC_DEP_NODEP;
1725
1726 if (start && end)
1727 {
1728 s = gfc_dep_compare_expr (start, end);
1729 /* Check for an empty range. */
1730 if (s == -1)
1731 return GFC_DEP_NODEP;
1732 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1733 return GFC_DEP_EQUAL;
1734 }
1735 }
1736 /* Unknown strides. */
1737 else
1738 {
1739 if (!start || !end)
1740 return GFC_DEP_OVERLAP;
1741 s = gfc_dep_compare_expr (start, end);
1742 if (s <= -2)
1743 return GFC_DEP_OVERLAP;
1744 /* Assume positive stride. */
1745 if (s == -1)
1746 {
1747 /* Check for elem < lower. */
1748 if (gfc_dep_compare_expr (elem, start) == -1)
1749 return GFC_DEP_NODEP;
1750 /* Check for elem > upper. */
1751 if (gfc_dep_compare_expr (elem, end) == 1)
1752 return GFC_DEP_NODEP;
1753 }
1754 /* Assume negative stride. */
1755 else if (s == 1)
1756 {
1757 /* Check for elem > upper. */
1758 if (gfc_dep_compare_expr (elem, start) == 1)
1759 return GFC_DEP_NODEP;
1760 /* Check for elem < lower. */
1761 if (gfc_dep_compare_expr (elem, end) == -1)
1762 return GFC_DEP_NODEP;
1763 }
1764 /* Equal bounds. */
1765 else if (s == 0)
1766 {
1767 s = gfc_dep_compare_expr (elem, start);
1768 if (s == 0)
1769 return GFC_DEP_EQUAL;
1770 if (s == 1 || s == -1)
1771 return GFC_DEP_NODEP;
1772 }
1773 }
1774
1775 return GFC_DEP_OVERLAP;
1776 }
1777
1778
1779 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1780 forall_index attribute. Return true if any variable may be
1781 being used as a FORALL index. Its safe to pessimistically
1782 return true, and assume a dependency. */
1783
1784 static bool
contains_forall_index_p(gfc_expr * expr)1785 contains_forall_index_p (gfc_expr *expr)
1786 {
1787 gfc_actual_arglist *arg;
1788 gfc_constructor *c;
1789 gfc_ref *ref;
1790 int i;
1791
1792 if (!expr)
1793 return false;
1794
1795 switch (expr->expr_type)
1796 {
1797 case EXPR_VARIABLE:
1798 if (expr->symtree->n.sym->forall_index)
1799 return true;
1800 break;
1801
1802 case EXPR_OP:
1803 if (contains_forall_index_p (expr->value.op.op1)
1804 || contains_forall_index_p (expr->value.op.op2))
1805 return true;
1806 break;
1807
1808 case EXPR_FUNCTION:
1809 for (arg = expr->value.function.actual; arg; arg = arg->next)
1810 if (contains_forall_index_p (arg->expr))
1811 return true;
1812 break;
1813
1814 case EXPR_CONSTANT:
1815 case EXPR_NULL:
1816 case EXPR_SUBSTRING:
1817 break;
1818
1819 case EXPR_STRUCTURE:
1820 case EXPR_ARRAY:
1821 for (c = gfc_constructor_first (expr->value.constructor);
1822 c; gfc_constructor_next (c))
1823 if (contains_forall_index_p (c->expr))
1824 return true;
1825 break;
1826
1827 default:
1828 gcc_unreachable ();
1829 }
1830
1831 for (ref = expr->ref; ref; ref = ref->next)
1832 switch (ref->type)
1833 {
1834 case REF_ARRAY:
1835 for (i = 0; i < ref->u.ar.dimen; i++)
1836 if (contains_forall_index_p (ref->u.ar.start[i])
1837 || contains_forall_index_p (ref->u.ar.end[i])
1838 || contains_forall_index_p (ref->u.ar.stride[i]))
1839 return true;
1840 break;
1841
1842 case REF_COMPONENT:
1843 break;
1844
1845 case REF_SUBSTRING:
1846 if (contains_forall_index_p (ref->u.ss.start)
1847 || contains_forall_index_p (ref->u.ss.end))
1848 return true;
1849 break;
1850
1851 default:
1852 gcc_unreachable ();
1853 }
1854
1855 return false;
1856 }
1857
1858 /* Determines overlapping for two single element array references. */
1859
1860 static gfc_dependency
gfc_check_element_vs_element(gfc_ref * lref,gfc_ref * rref,int n)1861 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1862 {
1863 gfc_array_ref l_ar;
1864 gfc_array_ref r_ar;
1865 gfc_expr *l_start;
1866 gfc_expr *r_start;
1867 int i;
1868
1869 l_ar = lref->u.ar;
1870 r_ar = rref->u.ar;
1871 l_start = l_ar.start[n] ;
1872 r_start = r_ar.start[n] ;
1873 i = gfc_dep_compare_expr (r_start, l_start);
1874 if (i == 0)
1875 return GFC_DEP_EQUAL;
1876
1877 /* Treat two scalar variables as potentially equal. This allows
1878 us to prove that a(i,:) and a(j,:) have no dependency. See
1879 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1880 Proceedings of the International Conference on Parallel and
1881 Distributed Processing Techniques and Applications (PDPTA2001),
1882 Las Vegas, Nevada, June 2001. */
1883 /* However, we need to be careful when either scalar expression
1884 contains a FORALL index, as these can potentially change value
1885 during the scalarization/traversal of this array reference. */
1886 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1887 return GFC_DEP_OVERLAP;
1888
1889 if (i > -2)
1890 return GFC_DEP_NODEP;
1891
1892 return GFC_DEP_EQUAL;
1893 }
1894
1895 /* Callback function for checking if an expression depends on a
1896 dummy variable which is any other than INTENT(IN). */
1897
1898 static int
callback_dummy_intent_not_in(gfc_expr ** ep,int * walk_subtrees ATTRIBUTE_UNUSED,void * data ATTRIBUTE_UNUSED)1899 callback_dummy_intent_not_in (gfc_expr **ep,
1900 int *walk_subtrees ATTRIBUTE_UNUSED,
1901 void *data ATTRIBUTE_UNUSED)
1902 {
1903 gfc_expr *e = *ep;
1904
1905 if (e->expr_type == EXPR_VARIABLE && e->symtree
1906 && e->symtree->n.sym->attr.dummy)
1907 return e->symtree->n.sym->attr.intent != INTENT_IN;
1908 else
1909 return 0;
1910 }
1911
1912 /* Auxiliary function to check if subexpressions have dummy variables which
1913 are not intent(in).
1914 */
1915
1916 static bool
dummy_intent_not_in(gfc_expr ** ep)1917 dummy_intent_not_in (gfc_expr **ep)
1918 {
1919 return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
1920 }
1921
1922 /* Determine if an array ref, usually an array section specifies the
1923 entire array. In addition, if the second, pointer argument is
1924 provided, the function will return true if the reference is
1925 contiguous; eg. (:, 1) gives true but (1,:) gives false.
1926 If one of the bounds depends on a dummy variable which is
1927 not INTENT(IN), also return false, because the user may
1928 have changed the variable. */
1929
1930 bool
gfc_full_array_ref_p(gfc_ref * ref,bool * contiguous)1931 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1932 {
1933 int i;
1934 int n;
1935 bool lbound_OK = true;
1936 bool ubound_OK = true;
1937
1938 if (contiguous)
1939 *contiguous = false;
1940
1941 if (ref->type != REF_ARRAY)
1942 return false;
1943
1944 if (ref->u.ar.type == AR_FULL)
1945 {
1946 if (contiguous)
1947 *contiguous = true;
1948 return true;
1949 }
1950
1951 if (ref->u.ar.type != AR_SECTION)
1952 return false;
1953 if (ref->next)
1954 return false;
1955
1956 for (i = 0; i < ref->u.ar.dimen; i++)
1957 {
1958 /* If we have a single element in the reference, for the reference
1959 to be full, we need to ascertain that the array has a single
1960 element in this dimension and that we actually reference the
1961 correct element. */
1962 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1963 {
1964 /* This is unconditionally a contiguous reference if all the
1965 remaining dimensions are elements. */
1966 if (contiguous)
1967 {
1968 *contiguous = true;
1969 for (n = i + 1; n < ref->u.ar.dimen; n++)
1970 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1971 *contiguous = false;
1972 }
1973
1974 if (!ref->u.ar.as
1975 || !ref->u.ar.as->lower[i]
1976 || !ref->u.ar.as->upper[i]
1977 || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1978 ref->u.ar.as->upper[i])
1979 || !ref->u.ar.start[i]
1980 || gfc_dep_compare_expr (ref->u.ar.start[i],
1981 ref->u.ar.as->lower[i]))
1982 return false;
1983 else
1984 continue;
1985 }
1986
1987 /* Check the lower bound. */
1988 if (ref->u.ar.start[i]
1989 && (!ref->u.ar.as
1990 || !ref->u.ar.as->lower[i]
1991 || gfc_dep_compare_expr (ref->u.ar.start[i],
1992 ref->u.ar.as->lower[i])
1993 || dummy_intent_not_in (&ref->u.ar.start[i])))
1994 lbound_OK = false;
1995 /* Check the upper bound. */
1996 if (ref->u.ar.end[i]
1997 && (!ref->u.ar.as
1998 || !ref->u.ar.as->upper[i]
1999 || gfc_dep_compare_expr (ref->u.ar.end[i],
2000 ref->u.ar.as->upper[i])
2001 || dummy_intent_not_in (&ref->u.ar.end[i])))
2002 ubound_OK = false;
2003 /* Check the stride. */
2004 if (ref->u.ar.stride[i]
2005 && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2006 return false;
2007
2008 /* This is unconditionally a contiguous reference as long as all
2009 the subsequent dimensions are elements. */
2010 if (contiguous)
2011 {
2012 *contiguous = true;
2013 for (n = i + 1; n < ref->u.ar.dimen; n++)
2014 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2015 *contiguous = false;
2016 }
2017
2018 if (!lbound_OK || !ubound_OK)
2019 return false;
2020 }
2021 return true;
2022 }
2023
2024
2025 /* Determine if a full array is the same as an array section with one
2026 variable limit. For this to be so, the strides must both be unity
2027 and one of either start == lower or end == upper must be true. */
2028
2029 static bool
ref_same_as_full_array(gfc_ref * full_ref,gfc_ref * ref)2030 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2031 {
2032 int i;
2033 bool upper_or_lower;
2034
2035 if (full_ref->type != REF_ARRAY)
2036 return false;
2037 if (full_ref->u.ar.type != AR_FULL)
2038 return false;
2039 if (ref->type != REF_ARRAY)
2040 return false;
2041 if (ref->u.ar.type == AR_FULL)
2042 return true;
2043 if (ref->u.ar.type != AR_SECTION)
2044 return false;
2045
2046 for (i = 0; i < ref->u.ar.dimen; i++)
2047 {
2048 /* If we have a single element in the reference, we need to check
2049 that the array has a single element and that we actually reference
2050 the correct element. */
2051 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2052 {
2053 if (!full_ref->u.ar.as
2054 || !full_ref->u.ar.as->lower[i]
2055 || !full_ref->u.ar.as->upper[i]
2056 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
2057 full_ref->u.ar.as->upper[i])
2058 || !ref->u.ar.start[i]
2059 || gfc_dep_compare_expr (ref->u.ar.start[i],
2060 full_ref->u.ar.as->lower[i]))
2061 return false;
2062 }
2063
2064 /* Check the strides. */
2065 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
2066 return false;
2067 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2068 return false;
2069
2070 upper_or_lower = false;
2071 /* Check the lower bound. */
2072 if (ref->u.ar.start[i]
2073 && (ref->u.ar.as
2074 && full_ref->u.ar.as->lower[i]
2075 && gfc_dep_compare_expr (ref->u.ar.start[i],
2076 full_ref->u.ar.as->lower[i]) == 0))
2077 upper_or_lower = true;
2078 /* Check the upper bound. */
2079 if (ref->u.ar.end[i]
2080 && (ref->u.ar.as
2081 && full_ref->u.ar.as->upper[i]
2082 && gfc_dep_compare_expr (ref->u.ar.end[i],
2083 full_ref->u.ar.as->upper[i]) == 0))
2084 upper_or_lower = true;
2085 if (!upper_or_lower)
2086 return false;
2087 }
2088 return true;
2089 }
2090
2091
2092 /* Finds if two array references are overlapping or not.
2093 Return value
2094 2 : array references are overlapping but reversal of one or
2095 more dimensions will clear the dependency.
2096 1 : array references are overlapping, or identical is true and
2097 there is some kind of overlap.
2098 0 : array references are identical or not overlapping. */
2099
2100 int
gfc_dep_resolver(gfc_ref * lref,gfc_ref * rref,gfc_reverse * reverse,bool identical)2101 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
2102 bool identical)
2103 {
2104 int n;
2105 int m;
2106 gfc_dependency fin_dep;
2107 gfc_dependency this_dep;
2108 bool same_component = false;
2109
2110 this_dep = GFC_DEP_ERROR;
2111 fin_dep = GFC_DEP_ERROR;
2112 /* Dependencies due to pointers should already have been identified.
2113 We only need to check for overlapping array references. */
2114
2115 while (lref && rref)
2116 {
2117 /* The refs might come in mixed, one with a _data component and one
2118 without. Look at their next reference in order to avoid an
2119 ICE. */
2120
2121 if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2122 && strcmp (lref->u.c.component->name, "_data") == 0)
2123 lref = lref->next;
2124
2125 if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2126 && strcmp (rref->u.c.component->name, "_data") == 0)
2127 rref = rref->next;
2128
2129 /* We're resolving from the same base symbol, so both refs should be
2130 the same type. We traverse the reference chain until we find ranges
2131 that are not equal. */
2132 gcc_assert (lref->type == rref->type);
2133 switch (lref->type)
2134 {
2135 case REF_COMPONENT:
2136 /* The two ranges can't overlap if they are from different
2137 components. */
2138 if (lref->u.c.component != rref->u.c.component)
2139 return 0;
2140
2141 same_component = true;
2142 break;
2143
2144 case REF_SUBSTRING:
2145 /* Substring overlaps are handled by the string assignment code
2146 if there is not an underlying dependency. */
2147 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2148
2149 case REF_ARRAY:
2150
2151 /* For now, treat all coarrays as dangerous. */
2152 if (lref->u.ar.codimen || rref->u.ar.codimen)
2153 return 1;
2154
2155 if (ref_same_as_full_array (lref, rref))
2156 return identical;
2157
2158 if (ref_same_as_full_array (rref, lref))
2159 return identical;
2160
2161 if (lref->u.ar.dimen != rref->u.ar.dimen)
2162 {
2163 if (lref->u.ar.type == AR_FULL)
2164 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
2165 : GFC_DEP_OVERLAP;
2166 else if (rref->u.ar.type == AR_FULL)
2167 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
2168 : GFC_DEP_OVERLAP;
2169 else
2170 return 1;
2171 break;
2172 }
2173
2174 /* Index for the reverse array. */
2175 m = -1;
2176 for (n = 0; n < lref->u.ar.dimen; n++)
2177 {
2178 /* Handle dependency when either of array reference is vector
2179 subscript. There is no dependency if the vector indices
2180 are equal or if indices are known to be different in a
2181 different dimension. */
2182 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2183 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2184 {
2185 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2186 && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2187 && gfc_dep_compare_expr (lref->u.ar.start[n],
2188 rref->u.ar.start[n]) == 0)
2189 this_dep = GFC_DEP_EQUAL;
2190 else
2191 this_dep = GFC_DEP_OVERLAP;
2192
2193 goto update_fin_dep;
2194 }
2195
2196 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2197 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2198 this_dep = check_section_vs_section (&lref->u.ar,
2199 &rref->u.ar, n);
2200 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2201 && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2202 this_dep = gfc_check_element_vs_section (lref, rref, n);
2203 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2204 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2205 this_dep = gfc_check_element_vs_section (rref, lref, n);
2206 else
2207 {
2208 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2209 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2210 this_dep = gfc_check_element_vs_element (rref, lref, n);
2211 if (identical && this_dep == GFC_DEP_EQUAL)
2212 this_dep = GFC_DEP_OVERLAP;
2213 }
2214
2215 /* If any dimension doesn't overlap, we have no dependency. */
2216 if (this_dep == GFC_DEP_NODEP)
2217 return 0;
2218
2219 /* Now deal with the loop reversal logic: This only works on
2220 ranges and is activated by setting
2221 reverse[n] == GFC_ENABLE_REVERSE
2222 The ability to reverse or not is set by previous conditions
2223 in this dimension. If reversal is not activated, the
2224 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2225
2226 /* Get the indexing right for the scalarizing loop. If this
2227 is an element, there is no corresponding loop. */
2228 if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2229 m++;
2230
2231 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2232 && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2233 {
2234 if (reverse)
2235 {
2236 /* Reverse if backward dependence and not inhibited. */
2237 if (reverse[m] == GFC_ENABLE_REVERSE
2238 && this_dep == GFC_DEP_BACKWARD)
2239 reverse[m] = GFC_REVERSE_SET;
2240
2241 /* Forward if forward dependence and not inhibited. */
2242 if (reverse[m] == GFC_ENABLE_REVERSE
2243 && this_dep == GFC_DEP_FORWARD)
2244 reverse[m] = GFC_FORWARD_SET;
2245
2246 /* Flag up overlap if dependence not compatible with
2247 the overall state of the expression. */
2248 if (reverse[m] == GFC_REVERSE_SET
2249 && this_dep == GFC_DEP_FORWARD)
2250 {
2251 reverse[m] = GFC_INHIBIT_REVERSE;
2252 this_dep = GFC_DEP_OVERLAP;
2253 }
2254 else if (reverse[m] == GFC_FORWARD_SET
2255 && this_dep == GFC_DEP_BACKWARD)
2256 {
2257 reverse[m] = GFC_INHIBIT_REVERSE;
2258 this_dep = GFC_DEP_OVERLAP;
2259 }
2260 }
2261
2262 /* If no intention of reversing or reversing is explicitly
2263 inhibited, convert backward dependence to overlap. */
2264 if ((!reverse && this_dep == GFC_DEP_BACKWARD)
2265 || (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
2266 this_dep = GFC_DEP_OVERLAP;
2267 }
2268
2269 /* Overlap codes are in order of priority. We only need to
2270 know the worst one.*/
2271
2272 update_fin_dep:
2273 if (identical && this_dep == GFC_DEP_EQUAL)
2274 this_dep = GFC_DEP_OVERLAP;
2275
2276 if (this_dep > fin_dep)
2277 fin_dep = this_dep;
2278 }
2279
2280 /* If this is an equal element, we have to keep going until we find
2281 the "real" array reference. */
2282 if (lref->u.ar.type == AR_ELEMENT
2283 && rref->u.ar.type == AR_ELEMENT
2284 && fin_dep == GFC_DEP_EQUAL)
2285 break;
2286
2287 /* Exactly matching and forward overlapping ranges don't cause a
2288 dependency. */
2289 if (fin_dep < GFC_DEP_BACKWARD && !identical)
2290 return 0;
2291
2292 /* Keep checking. We only have a dependency if
2293 subsequent references also overlap. */
2294 break;
2295
2296 case REF_INQUIRY:
2297 if (lref->u.i != rref->u.i)
2298 return 0;
2299
2300 break;
2301
2302 default:
2303 gcc_unreachable ();
2304 }
2305 lref = lref->next;
2306 rref = rref->next;
2307 }
2308
2309 /* Assume the worst if we nest to different depths. */
2310 if (lref || rref)
2311 return 1;
2312
2313 /* This can result from concatenation of assumed length string components. */
2314 if (same_component && fin_dep == GFC_DEP_ERROR)
2315 return 1;
2316
2317 /* If we haven't seen any array refs then something went wrong. */
2318 gcc_assert (fin_dep != GFC_DEP_ERROR);
2319
2320 if (identical && fin_dep != GFC_DEP_NODEP)
2321 return 1;
2322
2323 return fin_dep == GFC_DEP_OVERLAP;
2324 }
2325