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