Branch data Line data Source code
1 : : /* Dependency analysis
2 : : Copyright (C) 2000-2024 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 : 3255 : gfc_expr_is_one (gfc_expr *expr, int def)
63 : : {
64 : 3255 : gcc_assert (expr != NULL);
65 : :
66 : 3255 : if (expr->expr_type != EXPR_CONSTANT)
67 : : return def;
68 : :
69 : 2830 : if (expr->ts.type != BT_INTEGER)
70 : : return def;
71 : :
72 : 2830 : 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 : 1907 : identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2)
80 : : {
81 : 1907 : int i;
82 : :
83 : 1907 : if (a1->type == AR_FULL && a2->type == AR_FULL)
84 : : return true;
85 : :
86 : 477 : 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 : 392 : if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT)
104 : : {
105 : 368 : if (a1->dimen != a2->dimen)
106 : 0 : gfc_internal_error ("identical_array_ref(): inconsistent dimensions");
107 : :
108 : 517 : for (i = 0; i < a1->dimen; i++)
109 : : {
110 : 384 : 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 : 30617 : are_identical_variables (gfc_expr *e1, gfc_expr *e2)
125 : : {
126 : 30617 : gfc_ref *r1, *r2;
127 : :
128 : 30617 : if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy)
129 : : {
130 : : /* Dummy arguments: Only check for equal names. */
131 : 8254 : if (e1->symtree->n.sym->name != e2->symtree->n.sym->name)
132 : : return false;
133 : : }
134 : : else
135 : : {
136 : : /* Check for equal symbols. */
137 : 22363 : 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 : 10961 : if (e1->symtree->n.sym->attr.volatile_)
144 : : return false;
145 : :
146 : 10760 : r1 = e1->ref;
147 : 10760 : r2 = e2->ref;
148 : :
149 : 12651 : 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 : 2646 : if (r1 == NULL || r2 == NULL)
158 : : return false;
159 : :
160 : 2594 : if (r1->type != r2->type)
161 : : return false;
162 : :
163 : 2552 : switch (r1->type)
164 : : {
165 : :
166 : 1907 : case REF_ARRAY:
167 : 1907 : if (!identical_array_ref (&r1->u.ar, &r2->u.ar))
168 : : return false;
169 : :
170 : : break;
171 : :
172 : 524 : case REF_COMPONENT:
173 : 524 : if (r1->u.c.component != r2->u.c.component)
174 : : return false;
175 : : break;
176 : :
177 : 121 : case REF_SUBSTRING:
178 : 121 : 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 : 71 : if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
186 : : break;
187 : :
188 : 70 : 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 : 1891 : r1 = r1->next;
202 : 1891 : 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 : 30283 : gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
212 : : {
213 : :
214 : 30283 : gfc_actual_arglist *args1;
215 : 30283 : gfc_actual_arglist *args2;
216 : :
217 : 30283 : if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
218 : : return -2;
219 : :
220 : 29809 : if ((e1->value.function.esym && e2->value.function.esym
221 : 2785 : && e1->value.function.esym == e2->value.function.esym
222 : 558 : && (e1->value.function.esym->result->attr.pure || impure_ok))
223 : 29398 : || (e1->value.function.isym && e2->value.function.isym
224 : 25322 : && e1->value.function.isym == e2->value.function.isym
225 : 9841 : && (e1->value.function.isym->pure || impure_ok)))
226 : : {
227 : 10212 : args1 = e1->value.function.actual;
228 : 10212 : args2 = e2->value.function.actual;
229 : :
230 : : /* Compare the argument lists for equality. */
231 : 12980 : while (args1 && args2)
232 : : {
233 : : /* Bitwise xor, since C has no non-bitwise xor operator. */
234 : 11887 : if ((args1->expr == NULL) ^ (args2->expr == NULL))
235 : : return -2;
236 : :
237 : 11730 : if (args1->expr != NULL && args2->expr != NULL)
238 : : {
239 : 11023 : gfc_expr *e1, *e2;
240 : 11023 : e1 = args1->expr;
241 : 11023 : e2 = args2->expr;
242 : :
243 : 11023 : 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 : 2067 : if (e1->expr_type == EXPR_CONSTANT
251 : 294 : && 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 : 2768 : args1 = args1->next;
259 : 2768 : args2 = args2->next;
260 : : }
261 : 2186 : 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 : 456305 : gfc_discard_nops (gfc_expr *e)
272 : : {
273 : 456305 : gfc_actual_arglist *arglist;
274 : :
275 : 456305 : if (e == NULL)
276 : : return NULL;
277 : :
278 : 465786 : while (true)
279 : : {
280 : 465786 : if (e->expr_type == EXPR_OP
281 : 24135 : && (e->value.op.op == INTRINSIC_UPLUS
282 : 24135 : || e->value.op.op == INTRINSIC_PARENTHESES))
283 : : {
284 : 1227 : e = e->value.op.op1;
285 : 1227 : continue;
286 : : }
287 : :
288 : 464559 : if (e->expr_type == EXPR_FUNCTION && e->value.function.isym
289 : 44632 : && e->value.function.isym->id == GFC_ISYM_CONVERSION
290 : 9043 : && e->ts.type == BT_INTEGER)
291 : : {
292 : 8964 : arglist = e->value.function.actual;
293 : 8964 : if (arglist->expr->ts.type == BT_INTEGER
294 : 8950 : && e->ts.kind > arglist->expr->ts.kind)
295 : : {
296 : 8254 : e = arglist->expr;
297 : 8254 : 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 : 178878 : gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
318 : : {
319 : 178878 : int i;
320 : :
321 : 178878 : if (e1 == NULL && e2 == NULL)
322 : : return 0;
323 : 178876 : else if (e1 == NULL || e2 == NULL)
324 : : return -2;
325 : :
326 : 178875 : e1 = gfc_discard_nops (e1);
327 : 178875 : e2 = gfc_discard_nops (e2);
328 : :
329 : 178875 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
330 : : {
331 : : /* Compare X+C vs. X, for INTEGER only. */
332 : 4046 : if (e1->value.op.op2->expr_type == EXPR_CONSTANT
333 : 1530 : && e1->value.op.op2->ts.type == BT_INTEGER
334 : 5555 : && 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 : 3844 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
339 : : {
340 : 845 : int l, r;
341 : :
342 : 845 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
343 : 845 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
344 : 845 : 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 : 178081 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
372 : : {
373 : 3657 : if (e2->value.op.op2->expr_type == EXPR_CONSTANT
374 : 2009 : && e2->value.op.op2->ts.type == BT_INTEGER
375 : 5666 : && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
376 : 775 : return -mpz_sgn (e2->value.op.op2->value.integer);
377 : : }
378 : :
379 : : /* Compare X-C vs. X, for INTEGER only. */
380 : 177306 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
381 : : {
382 : 2186 : if (e1->value.op.op2->expr_type == EXPR_CONSTANT
383 : 1761 : && e1->value.op.op2->ts.type == BT_INTEGER
384 : 3935 : && 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 : 2106 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
389 : : {
390 : 888 : int l, r;
391 : :
392 : 888 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
393 : 888 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
394 : 888 : if (l == 0 && r == 0)
395 : : return 0;
396 : 179 : if (l > -2 && r == 0)
397 : : return l;
398 : 178 : if (l == 0 && r > -2)
399 : 6 : return -r;
400 : 172 : if (l == 1 && r == -1)
401 : : return 1;
402 : 172 : if (l == -1 && r == 1)
403 : : return -1;
404 : : }
405 : : }
406 : :
407 : : /* Compare A // B vs. C // D. */
408 : :
409 : 176510 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT
410 : 121 : && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT)
411 : : {
412 : 90 : int l, r;
413 : :
414 : 90 : l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
415 : 90 : r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
416 : :
417 : 90 : if (l != 0)
418 : : return l;
419 : :
420 : : /* Left expressions of // compare equal, but
421 : : watch out for 'A ' // x vs. 'A' // x. */
422 : 72 : gfc_expr *e1_left = e1->value.op.op1;
423 : 72 : gfc_expr *e2_left = e2->value.op.op1;
424 : :
425 : 72 : if (e1_left->expr_type == EXPR_CONSTANT
426 : 36 : && e2_left->expr_type == EXPR_CONSTANT
427 : 36 : && e1_left->value.character.length
428 : 36 : != 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 : 176420 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
436 : : {
437 : 3557 : if (e2->value.op.op2->expr_type == EXPR_CONSTANT
438 : 2723 : && e2->value.op.op2->ts.type == BT_INTEGER
439 : 6254 : && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
440 : 2054 : return mpz_sgn (e2->value.op.op2->value.integer);
441 : : }
442 : :
443 : :
444 : 174366 : 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 : 174360 : if (e1->expr_type != e2->expr_type)
476 : : return -3;
477 : :
478 : 63788 : switch (e1->expr_type)
479 : : {
480 : 28025 : case EXPR_CONSTANT:
481 : : /* Compare strings for equality. */
482 : 28025 : if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER)
483 : 122 : 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 : 27903 : if (e2->expr_type == EXPR_CONSTANT)
489 : : {
490 : 27903 : if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL)
491 : : {
492 : 34 : if (mpfr_cmp (e1->value.real, e2->value.real) == 0)
493 : : return 0;
494 : : else
495 : : return -2;
496 : : }
497 : 27869 : 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 : 27864 : 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 : 27849 : gcc_assert (e2->expr_type == EXPR_CONSTANT);
512 : :
513 : 27849 : i = mpz_cmp (e1->value.integer, e2->value.integer);
514 : 27849 : if (i == 0)
515 : : return 0;
516 : 15790 : else if (i < 0)
517 : : return -1;
518 : : return 1;
519 : :
520 : 30617 : case EXPR_VARIABLE:
521 : 30617 : if (are_identical_variables (e1, e2))
522 : : return 0;
523 : : else
524 : : return -3;
525 : :
526 : 1876 : case EXPR_OP:
527 : : /* Intrinsic operators are the same if their operands are the same. */
528 : 1876 : if (e1->value.op.op != e2->value.op.op)
529 : : return -2;
530 : 1581 : 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 : 1552 : if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
536 : 1552 : && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
537 : : return 0;
538 : 1242 : else if (e1->value.op.op == INTRINSIC_TIMES
539 : 222 : && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0
540 : 1388 : && 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 : 3022 : case EXPR_FUNCTION:
547 : 3022 : 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 : 82403 : gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
566 : : {
567 : 82403 : gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2;
568 : :
569 : 82403 : if (e1 == NULL || e2 == NULL)
570 : : return false;
571 : :
572 : 45900 : if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
573 : : return false;
574 : :
575 : 45899 : e1 = gfc_discard_nops (e1);
576 : 45899 : e2 = gfc_discard_nops (e2);
577 : :
578 : : /* Initialize tentatively, clear if we don't return anything. */
579 : 45899 : mpz_init (*result);
580 : :
581 : : /* Case 1: c1 - c2 = c1 - c2, trivially. */
582 : :
583 : 45899 : if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT)
584 : : {
585 : 36773 : mpz_sub (*result, e1->value.integer, e2->value.integer);
586 : 36773 : return true;
587 : : }
588 : :
589 : 9126 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
590 : : {
591 : 867 : e1_op1 = gfc_discard_nops (e1->value.op.op1);
592 : 867 : e1_op2 = gfc_discard_nops (e1->value.op.op2);
593 : :
594 : : /* Case 2: (X + c1) - X = c1. */
595 : 867 : if (e1_op2->expr_type == EXPR_CONSTANT
596 : 867 : && gfc_dep_compare_expr (e1_op1, e2) == 0)
597 : : {
598 : 237 : mpz_set (*result, e1_op2->value.integer);
599 : 237 : return true;
600 : : }
601 : :
602 : : /* Case 3: (c1 + X) - X = c1. */
603 : 630 : if (e1_op1->expr_type == EXPR_CONSTANT
604 : 630 : && 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 : 624 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
611 : : {
612 : 251 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
613 : 251 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
614 : :
615 : 251 : if (e1_op2->expr_type == EXPR_CONSTANT)
616 : : {
617 : : /* Case 4: X + c1 - (X + c2) = c1 - c2. */
618 : 168 : if (e2_op2->expr_type == EXPR_CONSTANT
619 : 168 : && gfc_dep_compare_expr (e1_op1, e2_op1) == 0)
620 : : {
621 : 128 : mpz_sub (*result, e1_op2->value.integer,
622 : 128 : e2_op2->value.integer);
623 : 128 : 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 : 478 : 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 : 8719 : if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
686 : : {
687 : 801 : e1_op1 = gfc_discard_nops (e1->value.op.op1);
688 : 801 : e1_op2 = gfc_discard_nops (e1->value.op.op2);
689 : :
690 : 801 : if (e1_op2->expr_type == EXPR_CONSTANT)
691 : : {
692 : : /* Case 10: (X - c1) - X = -c1 */
693 : :
694 : 757 : 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 : 751 : 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 : 739 : 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 : 777 : 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 : 8689 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
761 : : {
762 : 251 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
763 : 251 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
764 : :
765 : : /* Case 15: X - (X + c2) = -c2. */
766 : 251 : if (e2_op2->expr_type == EXPR_CONSTANT
767 : 251 : && gfc_dep_compare_expr (e1, e2_op1) == 0)
768 : : {
769 : 12 : mpz_neg (*result, e2_op2->value.integer);
770 : 12 : return true;
771 : : }
772 : : /* Case 16: X - (c2 + X) = -c2. */
773 : 239 : if (e2_op1->expr_type == EXPR_CONSTANT
774 : 239 : && 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 : 8671 : if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
782 : : {
783 : 118 : e2_op1 = gfc_discard_nops (e2->value.op.op1);
784 : 118 : e2_op2 = gfc_discard_nops (e2->value.op.op2);
785 : :
786 : : /* Case 17: X - (X - c2) = c2. */
787 : 118 : if (e2_op2->expr_type == EXPR_CONSTANT
788 : 118 : && 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 : 8616 : if (gfc_dep_compare_expr (e1, e2) == 0)
796 : : {
797 : : /* Case 18: X - X = 0. */
798 : 1602 : mpz_set_si (*result, 0);
799 : 1602 : return true;
800 : : }
801 : :
802 : 7014 : mpz_clear (*result);
803 : 7014 : 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 : 2376 : is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n)
811 : : {
812 : 2376 : gfc_expr *e1;
813 : 2376 : gfc_expr *e2;
814 : 2376 : int i;
815 : :
816 : : /* TODO: More sophisticated range comparison. */
817 : 2376 : gcc_assert (ar1 && ar2);
818 : :
819 : 2376 : gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
820 : :
821 : 2376 : e1 = ar1->stride[n];
822 : 2376 : e2 = ar2->stride[n];
823 : : /* Check for mismatching strides. A NULL stride means a stride of 1. */
824 : 2376 : 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 : 2313 : else if (e2 && !e1)
831 : : {
832 : 201 : i = gfc_expr_is_one (e2, -1);
833 : 201 : if (i == -1 || i == 0)
834 : : return 0;
835 : : }
836 : 2112 : else if (e1 && e2)
837 : : {
838 : 238 : i = gfc_dep_compare_expr (e1, e2);
839 : 238 : if (i != 0)
840 : : return 0;
841 : : }
842 : : /* The strides match. */
843 : :
844 : : /* Check the range start. */
845 : 2007 : e1 = ar1->start[n];
846 : 2007 : e2 = ar2->start[n];
847 : 2007 : if (e1 || e2)
848 : : {
849 : : /* Use the bound of the array if no bound is specified. */
850 : 1159 : if (ar1->as && !e1)
851 : 177 : e1 = ar1->as->lower[n];
852 : :
853 : 1159 : if (ar2->as && !e2)
854 : 34 : e2 = ar2->as->lower[n];
855 : :
856 : : /* Check we have values for both. */
857 : 1159 : if (!(e1 && e2))
858 : : return 0;
859 : :
860 : 981 : i = gfc_dep_compare_expr (e1, e2);
861 : 981 : if (i != 0)
862 : : return 0;
863 : : }
864 : :
865 : : /* Check the range end. */
866 : 1258 : e1 = ar1->end[n];
867 : 1258 : e2 = ar2->end[n];
868 : 1258 : if (e1 || e2)
869 : : {
870 : : /* Use the bound of the array if no bound is specified. */
871 : 452 : if (ar1->as && !e1)
872 : 11 : e1 = ar1->as->upper[n];
873 : :
874 : 452 : if (ar2->as && !e2)
875 : 0 : e2 = ar2->as->upper[n];
876 : :
877 : : /* Check we have values for both. */
878 : 452 : 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 : 235784 : gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
901 : : {
902 : 235784 : if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
903 : : return NULL;
904 : :
905 : 41378 : switch (expr->value.function.isym->id)
906 : : {
907 : 1729 : case GFC_ISYM_TRANSPOSE:
908 : 1729 : 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 : 136883 : gfc_ref_needs_temporary_p (gfc_ref *ref)
921 : : {
922 : 136883 : int n;
923 : 136883 : bool subarray_p;
924 : :
925 : 136883 : subarray_p = false;
926 : 293453 : for (; ref; ref = ref->next)
927 : 157033 : switch (ref->type)
928 : : {
929 : 137157 : case REF_ARRAY:
930 : : /* Vector dimensions are generally not monotonic and must be
931 : : handled using a temporary. */
932 : 137157 : if (ref->u.ar.type == AR_SECTION)
933 : 58757 : for (n = 0; n < ref->u.ar.dimen; n++)
934 : 35700 : 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 : 12822 : gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
988 : : gfc_expr *expr, gfc_dep_check elemental)
989 : : {
990 : 12997 : gfc_expr *arg;
991 : :
992 : 12997 : gcc_assert (var->expr_type == EXPR_VARIABLE);
993 : 12997 : gcc_assert (var->rank > 0);
994 : :
995 : 12997 : switch (expr->expr_type)
996 : : {
997 : 7933 : case EXPR_VARIABLE:
998 : : /* In case of elemental subroutines, there is no dependency
999 : : between two same-range array references. */
1000 : 7933 : if (gfc_ref_needs_temporary_p (expr->ref)
1001 : 7933 : || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
1002 : : {
1003 : 617 : 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 : 1551 : case EXPR_FUNCTION:
1039 : 1551 : if (intent != INTENT_IN)
1040 : : {
1041 : 1547 : arg = gfc_get_noncopying_intrinsic_argument (expr);
1042 : 1547 : if (arg != NULL)
1043 : : return gfc_check_argument_var_dependency (var, intent, arg,
1044 : : NOT_ELEMENTAL);
1045 : : }
1046 : :
1047 : 1376 : if (elemental != NOT_ELEMENTAL)
1048 : : {
1049 : 128 : if ((expr->value.function.esym
1050 : 82 : && expr->value.function.esym->attr.elemental)
1051 : 58 : || (expr->value.function.isym
1052 : 46 : && 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 : 52 : if (gfc_inline_intrinsic_function_p (expr))
1058 : : {
1059 : : /* The TRANSPOSE case should have been caught in the
1060 : : noncopying intrinsic case above. */
1061 : 24 : gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
1062 : :
1063 : 24 : return gfc_check_fncall_dependency (var, intent, NULL,
1064 : : expr->value.function.actual,
1065 : 24 : ELEM_CHECK_VARIABLE);
1066 : : }
1067 : : }
1068 : : return 0;
1069 : :
1070 : 96 : 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 : 96 : 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 : 12768 : gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
1102 : : gfc_expr *expr, gfc_dep_check elemental)
1103 : : {
1104 : 12854 : switch (other->expr_type)
1105 : : {
1106 : 12768 : case EXPR_VARIABLE:
1107 : 12768 : 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 : 6509 : 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 : 6509 : gfc_formal_arglist *formal;
1132 : 6509 : gfc_expr *expr;
1133 : :
1134 : 6509 : formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL;
1135 : 40707 : for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
1136 : : {
1137 : 17734 : expr = actual->expr;
1138 : :
1139 : : /* Skip args which are not present. */
1140 : 17734 : if (!expr)
1141 : 3305 : continue;
1142 : :
1143 : : /* Skip other itself. */
1144 : 14429 : if (expr == other)
1145 : 1423 : continue;
1146 : :
1147 : : /* Skip intent(in) arguments if OTHER itself is intent(in). */
1148 : 13006 : if (formal && intent == INTENT_IN
1149 : 270 : && formal->sym->attr.intent == INTENT_IN)
1150 : 238 : continue;
1151 : :
1152 : 12768 : 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 : 52426 : gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
1174 : : {
1175 : 52426 : gfc_equiv_list *l;
1176 : 52426 : gfc_equiv_info *s, *fl1, *fl2;
1177 : :
1178 : 52426 : gcc_assert (e1->expr_type == EXPR_VARIABLE
1179 : : && e2->expr_type == EXPR_VARIABLE);
1180 : :
1181 : 52426 : 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 : 512 : check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
1238 : : {
1239 : 512 : gfc_component *cm1;
1240 : 512 : gfc_symbol *sym1;
1241 : 512 : gfc_symbol *sym2;
1242 : 512 : gfc_ref *ref1;
1243 : 512 : bool seen_component_ref;
1244 : :
1245 : 512 : if (expr1->expr_type != EXPR_VARIABLE
1246 : 512 : || expr2->expr_type != EXPR_VARIABLE)
1247 : : return false;
1248 : :
1249 : 512 : sym1 = expr1->symtree->n.sym;
1250 : 512 : sym2 = expr2->symtree->n.sym;
1251 : :
1252 : : /* Keep it simple for now. */
1253 : 512 : if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
1254 : : return false;
1255 : :
1256 : 440 : if (sym1->attr.pointer)
1257 : : {
1258 : 245 : if (gfc_compare_types (&sym1->ts, &sym2->ts))
1259 : : return false;
1260 : : }
1261 : :
1262 : : /* This is a conservative check on the components of the derived type
1263 : : if no component references have been seen. Since we will not dig
1264 : : into the components of derived type components, we play it safe by
1265 : : returning false. First we check the reference chain and then, if
1266 : : no component references have been seen, the components. */
1267 : 224 : seen_component_ref = false;
1268 : 224 : if (sym1->ts.type == BT_DERIVED)
1269 : : {
1270 : 102 : for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
1271 : : {
1272 : 82 : if (ref1->type != REF_COMPONENT)
1273 : 31 : continue;
1274 : :
1275 : 51 : if (ref1->u.c.component->ts.type == BT_DERIVED)
1276 : : return false;
1277 : :
1278 : 26 : if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
1279 : 52 : && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
1280 : : return false;
1281 : :
1282 : : seen_component_ref = true;
1283 : : }
1284 : : }
1285 : :
1286 : 193 : if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
1287 : : {
1288 : 0 : for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
1289 : : {
1290 : 0 : if (cm1->ts.type == BT_DERIVED)
1291 : : return false;
1292 : :
1293 : 0 : if ((sym2->attr.pointer || cm1->attr.pointer)
1294 : 0 : && gfc_compare_types (&cm1->ts, &sym2->ts))
1295 : : return false;
1296 : : }
1297 : : }
1298 : :
1299 : : return true;
1300 : : }
1301 : :
1302 : :
1303 : : /* Return true if the statement body redefines the condition. Returns
1304 : : true if expr2 depends on expr1. expr1 should be a single term
1305 : : suitable for the lhs of an assignment. The IDENTICAL flag indicates
1306 : : whether array references to the same symbol with identical range
1307 : : references count as a dependency or not. Used for forall and where
1308 : : statements. Also used with functions returning arrays without a
1309 : : temporary. */
1310 : :
1311 : : int
1312 : 110864 : gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
1313 : : {
1314 : 110864 : gfc_actual_arglist *actual;
1315 : 110864 : gfc_constructor *c;
1316 : 110864 : int n;
1317 : :
1318 : : /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION
1319 : : and a reference to _F.caf_get, so skip the assert. */
1320 : 110864 : if (expr1->expr_type == EXPR_FUNCTION
1321 : 0 : && strcmp (expr1->value.function.name, "_F.caf_get") == 0)
1322 : : return 0;
1323 : :
1324 : 110864 : if (expr1->expr_type != EXPR_VARIABLE)
1325 : 0 : gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE");
1326 : :
1327 : : /* Prevent NULL pointer dereference while recursively analyzing invalid
1328 : : expressions. */
1329 : 110864 : if (expr2 == NULL)
1330 : : return 0;
1331 : :
1332 : 110863 : switch (expr2->expr_type)
1333 : : {
1334 : 8622 : case EXPR_OP:
1335 : 8622 : n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
1336 : 8622 : if (n)
1337 : : return n;
1338 : 7414 : if (expr2->value.op.op2)
1339 : 7055 : return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
1340 : : return 0;
1341 : :
1342 : 49975 : case EXPR_VARIABLE:
1343 : : /* The interesting cases are when the symbols don't match. */
1344 : 49975 : if (expr1->symtree->n.sym != expr2->symtree->n.sym)
1345 : : {
1346 : 44403 : symbol_attribute attr1, attr2;
1347 : 44403 : gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
1348 : 44403 : gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
1349 : :
1350 : : /* Return 1 if expr1 and expr2 are equivalenced arrays. */
1351 : 44403 : if (gfc_are_equivalenced_arrays (expr1, expr2))
1352 : : return 1;
1353 : :
1354 : : /* Symbols can only alias if they have the same type. */
1355 : 44327 : if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
1356 : 44327 : && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
1357 : : {
1358 : 38113 : if (ts1->type != ts2->type || ts1->kind != ts2->kind)
1359 : : return 0;
1360 : : }
1361 : :
1362 : : /* We have to also include target-target as ptr%comp is not a
1363 : : pointer but it still alias with "dt%comp" for "ptr => dt". As
1364 : : subcomponents and array access to pointers retains the target
1365 : : attribute, that's sufficient. */
1366 : 35629 : attr1 = gfc_expr_attr (expr1);
1367 : 35629 : attr2 = gfc_expr_attr (expr2);
1368 : 35629 : if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target))
1369 : : {
1370 : 391 : if (check_data_pointer_types (expr1, expr2)
1371 : 391 : && check_data_pointer_types (expr2, expr1))
1372 : : return 0;
1373 : :
1374 : 319 : return 1;
1375 : : }
1376 : : else
1377 : : {
1378 : 35238 : gfc_symbol *sym1 = expr1->symtree->n.sym;
1379 : 35238 : gfc_symbol *sym2 = expr2->symtree->n.sym;
1380 : 35238 : if (sym1->attr.target && sym2->attr.target
1381 : 0 : && ((sym1->attr.dummy && !sym1->attr.contiguous
1382 : 0 : && (!sym1->attr.dimension
1383 : 0 : || sym2->as->type == AS_ASSUMED_SHAPE))
1384 : 0 : || (sym2->attr.dummy && !sym2->attr.contiguous
1385 : 0 : && (!sym2->attr.dimension
1386 : 0 : || sym2->as->type == AS_ASSUMED_SHAPE))))
1387 : : return 1;
1388 : : }
1389 : :
1390 : : /* Otherwise distinct symbols have no dependencies. */
1391 : : return 0;
1392 : : }
1393 : :
1394 : : /* Identical and disjoint ranges return 0,
1395 : : overlapping ranges return 1. */
1396 : 5572 : if (expr1->ref && expr2->ref)
1397 : 5476 : return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical);
1398 : :
1399 : : return 1;
1400 : :
1401 : 15877 : case EXPR_FUNCTION:
1402 : 15877 : if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL)
1403 : 404 : identical = 1;
1404 : :
1405 : : /* Remember possible differences between elemental and
1406 : : transformational functions. All functions inside a FORALL
1407 : : will be pure. */
1408 : 15877 : for (actual = expr2->value.function.actual;
1409 : 52505 : actual; actual = actual->next)
1410 : : {
1411 : 38084 : if (!actual->expr)
1412 : 7366 : continue;
1413 : 30718 : n = gfc_check_dependency (expr1, actual->expr, identical);
1414 : 30718 : if (n)
1415 : 1456 : return n;
1416 : : }
1417 : : return 0;
1418 : :
1419 : : case EXPR_CONSTANT:
1420 : : case EXPR_NULL:
1421 : : return 0;
1422 : :
1423 : 11695 : case EXPR_ARRAY:
1424 : : /* Loop through the array constructor's elements. */
1425 : 11695 : for (c = gfc_constructor_first (expr2->value.constructor);
1426 : 82936 : c; c = gfc_constructor_next (c))
1427 : : {
1428 : : /* If this is an iterator, assume the worst. */
1429 : 72337 : if (c->iterator)
1430 : : return 1;
1431 : : /* Avoid recursion in the common case. */
1432 : 71772 : if (c->expr->expr_type == EXPR_CONSTANT)
1433 : 69446 : continue;
1434 : 2326 : if (gfc_check_dependency (expr1, c->expr, 1))
1435 : : return 1;
1436 : : }
1437 : : return 0;
1438 : :
1439 : : default:
1440 : : return 1;
1441 : : }
1442 : : }
1443 : :
1444 : :
1445 : : /* Determines overlapping for two array sections. */
1446 : :
1447 : : static gfc_dependency
1448 : 2376 : check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
1449 : : {
1450 : 2376 : gfc_expr *l_start;
1451 : 2376 : gfc_expr *l_end;
1452 : 2376 : gfc_expr *l_stride;
1453 : 2376 : gfc_expr *l_lower;
1454 : 2376 : gfc_expr *l_upper;
1455 : 2376 : int l_dir;
1456 : :
1457 : 2376 : gfc_expr *r_start;
1458 : 2376 : gfc_expr *r_end;
1459 : 2376 : gfc_expr *r_stride;
1460 : 2376 : gfc_expr *r_lower;
1461 : 2376 : gfc_expr *r_upper;
1462 : 2376 : gfc_expr *one_expr;
1463 : 2376 : int r_dir;
1464 : 2376 : int stride_comparison;
1465 : 2376 : int start_comparison;
1466 : 2376 : mpz_t tmp;
1467 : :
1468 : : /* If they are the same range, return without more ado. */
1469 : 2376 : if (is_same_range (l_ar, r_ar, n))
1470 : : return GFC_DEP_EQUAL;
1471 : :
1472 : 1151 : l_start = l_ar->start[n];
1473 : 1151 : l_end = l_ar->end[n];
1474 : 1151 : l_stride = l_ar->stride[n];
1475 : :
1476 : 1151 : r_start = r_ar->start[n];
1477 : 1151 : r_end = r_ar->end[n];
1478 : 1151 : r_stride = r_ar->stride[n];
1479 : :
1480 : : /* If l_start is NULL take it from array specifier. */
1481 : 1151 : if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1482 : 122 : l_start = l_ar->as->lower[n];
1483 : : /* If l_end is NULL take it from array specifier. */
1484 : 1151 : if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as))
1485 : 135 : l_end = l_ar->as->upper[n];
1486 : :
1487 : : /* If r_start is NULL take it from array specifier. */
1488 : 1151 : if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1489 : 40 : r_start = r_ar->as->lower[n];
1490 : : /* If r_end is NULL take it from array specifier. */
1491 : 1151 : if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as))
1492 : 28 : r_end = r_ar->as->upper[n];
1493 : :
1494 : : /* Determine whether the l_stride is positive or negative. */
1495 : 1151 : if (!l_stride)
1496 : : l_dir = 1;
1497 : 295 : else if (l_stride->expr_type == EXPR_CONSTANT
1498 : 214 : && l_stride->ts.type == BT_INTEGER)
1499 : 214 : l_dir = mpz_sgn (l_stride->value.integer);
1500 : 81 : else if (l_start && l_end)
1501 : 81 : l_dir = gfc_dep_compare_expr (l_end, l_start);
1502 : : else
1503 : : l_dir = -2;
1504 : :
1505 : : /* Determine whether the r_stride is positive or negative. */
1506 : 1151 : if (!r_stride)
1507 : : r_dir = 1;
1508 : 433 : else if (r_stride->expr_type == EXPR_CONSTANT
1509 : 391 : && r_stride->ts.type == BT_INTEGER)
1510 : 391 : r_dir = mpz_sgn (r_stride->value.integer);
1511 : 42 : else if (r_start && r_end)
1512 : 42 : r_dir = gfc_dep_compare_expr (r_end, r_start);
1513 : : else
1514 : : r_dir = -2;
1515 : :
1516 : : /* The strides should never be zero. */
1517 : 1151 : if (l_dir == 0 || r_dir == 0)
1518 : : return GFC_DEP_OVERLAP;
1519 : :
1520 : : /* Determine the relationship between the strides. Set stride_comparison to
1521 : : -2 if the dependency cannot be determined
1522 : : -1 if l_stride < r_stride
1523 : : 0 if l_stride == r_stride
1524 : : 1 if l_stride > r_stride
1525 : : as determined by gfc_dep_compare_expr. */
1526 : :
1527 : 1151 : one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1);
1528 : :
1529 : 2725 : stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr,
1530 : : r_stride ? r_stride : one_expr);
1531 : :
1532 : 1151 : if (l_start && r_start)
1533 : 900 : start_comparison = gfc_dep_compare_expr (l_start, r_start);
1534 : : else
1535 : : start_comparison = -2;
1536 : :
1537 : 1151 : gfc_free_expr (one_expr);
1538 : :
1539 : : /* Determine LHS upper and lower bounds. */
1540 : 1151 : if (l_dir == 1)
1541 : : {
1542 : : l_lower = l_start;
1543 : : l_upper = l_end;
1544 : : }
1545 : 181 : else if (l_dir == -1)
1546 : : {
1547 : : l_lower = l_end;
1548 : : l_upper = l_start;
1549 : : }
1550 : : else
1551 : : {
1552 : 37 : l_lower = NULL;
1553 : 37 : l_upper = NULL;
1554 : : }
1555 : :
1556 : : /* Determine RHS upper and lower bounds. */
1557 : 1151 : if (r_dir == 1)
1558 : : {
1559 : : r_lower = r_start;
1560 : : r_upper = r_end;
1561 : : }
1562 : 305 : else if (r_dir == -1)
1563 : : {
1564 : : r_lower = r_end;
1565 : : r_upper = r_start;
1566 : : }
1567 : : else
1568 : : {
1569 : 20 : r_lower = NULL;
1570 : 20 : r_upper = NULL;
1571 : : }
1572 : :
1573 : : /* Check whether the ranges are disjoint. */
1574 : 1151 : if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
1575 : : return GFC_DEP_NODEP;
1576 : 1138 : if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
1577 : : return GFC_DEP_NODEP;
1578 : :
1579 : : /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */
1580 : 1052 : if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
1581 : : {
1582 : 34 : if (l_dir == 1 && r_dir == -1)
1583 : : return GFC_DEP_EQUAL;
1584 : 21 : if (l_dir == -1 && r_dir == 1)
1585 : : return GFC_DEP_EQUAL;
1586 : : }
1587 : :
1588 : : /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */
1589 : 1037 : if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
1590 : : {
1591 : 39 : if (l_dir == 1 && r_dir == -1)
1592 : : return GFC_DEP_EQUAL;
1593 : 39 : if (l_dir == -1 && r_dir == 1)
1594 : : return GFC_DEP_EQUAL;
1595 : : }
1596 : :
1597 : : /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP.
1598 : : There is no dependency if the remainder of
1599 : : (l_start - r_start) / gcd(l_stride, r_stride) is
1600 : : nonzero.
1601 : : TODO:
1602 : : - Cases like a(1:4:2) = a(2:3) are still not handled.
1603 : : */
1604 : :
1605 : : #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \
1606 : : && (a)->ts.type == BT_INTEGER)
1607 : :
1608 : 252 : if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride)
1609 : 1164 : && gfc_dep_difference (l_start, r_start, &tmp))
1610 : : {
1611 : 153 : mpz_t gcd;
1612 : 153 : int result;
1613 : :
1614 : 153 : mpz_init (gcd);
1615 : 153 : mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer);
1616 : :
1617 : 153 : mpz_fdiv_r (tmp, tmp, gcd);
1618 : 153 : result = mpz_cmp_si (tmp, 0L);
1619 : :
1620 : 153 : mpz_clear (gcd);
1621 : 153 : mpz_clear (tmp);
1622 : :
1623 : 153 : if (result != 0)
1624 : 29 : return GFC_DEP_NODEP;
1625 : : }
1626 : :
1627 : : #undef IS_CONSTANT_INTEGER
1628 : :
1629 : : /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */
1630 : :
1631 : 980 : if (l_dir == 1 && r_dir == 1 &&
1632 : 648 : (start_comparison == 0 || start_comparison == -1)
1633 : 183 : && (stride_comparison == 0 || stride_comparison == -1))
1634 : : return GFC_DEP_FORWARD;
1635 : :
1636 : : /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
1637 : : x:y:-1 vs. x:y:-2. */
1638 : 799 : if (l_dir == -1 && r_dir == -1 &&
1639 : 87 : (start_comparison == 0 || start_comparison == 1)
1640 : 87 : && (stride_comparison == 0 || stride_comparison == 1))
1641 : : return GFC_DEP_FORWARD;
1642 : :
1643 : 753 : if (stride_comparison == 0 || stride_comparison == -1)
1644 : : {
1645 : 471 : if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1646 : : {
1647 : :
1648 : : /* Check for a(low:y:s) vs. a(z:x:s) or
1649 : : a(low:y:s) vs. a(z:x:s+1) where a has a lower bound
1650 : : of low, which is always at least a forward dependence. */
1651 : :
1652 : 262 : if (r_dir == 1
1653 : 262 : && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0)
1654 : : return GFC_DEP_FORWARD;
1655 : : }
1656 : : }
1657 : :
1658 : 751 : if (stride_comparison == 0 || stride_comparison == 1)
1659 : : {
1660 : 659 : if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
1661 : : {
1662 : :
1663 : : /* Check for a(high:y:-s) vs. a(z:x:-s) or
1664 : : a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
1665 : : of high, which is always at least a forward dependence. */
1666 : :
1667 : 375 : if (r_dir == -1
1668 : 375 : && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0)
1669 : : return GFC_DEP_FORWARD;
1670 : : }
1671 : : }
1672 : :
1673 : :
1674 : 657 : if (stride_comparison == 0)
1675 : : {
1676 : : /* From here, check for backwards dependencies. */
1677 : : /* x+1:y vs. x:z. */
1678 : 456 : if (l_dir == 1 && r_dir == 1 && start_comparison == 1)
1679 : : return GFC_DEP_BACKWARD;
1680 : :
1681 : : /* x-1:y:-1 vs. x:z:-1. */
1682 : 225 : if (l_dir == -1 && r_dir == -1 && start_comparison == -1)
1683 : : return GFC_DEP_BACKWARD;
1684 : : }
1685 : :
1686 : : return GFC_DEP_OVERLAP;
1687 : : }
1688 : :
1689 : :
1690 : : /* Determines overlapping for a single element and a section. */
1691 : :
1692 : : static gfc_dependency
1693 : 308 : gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1694 : : {
1695 : 308 : gfc_array_ref *ref;
1696 : 308 : gfc_expr *elem;
1697 : 308 : gfc_expr *start;
1698 : 308 : gfc_expr *end;
1699 : 308 : gfc_expr *stride;
1700 : 308 : int s;
1701 : :
1702 : 308 : elem = lref->u.ar.start[n];
1703 : 308 : if (!elem)
1704 : : return GFC_DEP_OVERLAP;
1705 : :
1706 : 308 : ref = &rref->u.ar;
1707 : 308 : start = ref->start[n] ;
1708 : 308 : end = ref->end[n] ;
1709 : 308 : stride = ref->stride[n];
1710 : :
1711 : 308 : if (!start && IS_ARRAY_EXPLICIT (ref->as))
1712 : 105 : start = ref->as->lower[n];
1713 : 308 : if (!end && IS_ARRAY_EXPLICIT (ref->as))
1714 : 105 : end = ref->as->upper[n];
1715 : :
1716 : : /* Determine whether the stride is positive or negative. */
1717 : 308 : if (!stride)
1718 : : s = 1;
1719 : 0 : else if (stride->expr_type == EXPR_CONSTANT
1720 : 0 : && stride->ts.type == BT_INTEGER)
1721 : 0 : s = mpz_sgn (stride->value.integer);
1722 : : else
1723 : : s = -2;
1724 : :
1725 : : /* Stride should never be zero. */
1726 : 0 : if (s == 0)
1727 : : return GFC_DEP_OVERLAP;
1728 : :
1729 : : /* Positive strides. */
1730 : 308 : if (s == 1)
1731 : : {
1732 : : /* Check for elem < lower. */
1733 : 308 : if (start && gfc_dep_compare_expr (elem, start) == -1)
1734 : : return GFC_DEP_NODEP;
1735 : : /* Check for elem > upper. */
1736 : 307 : if (end && gfc_dep_compare_expr (elem, end) == 1)
1737 : : return GFC_DEP_NODEP;
1738 : :
1739 : 307 : if (start && end)
1740 : : {
1741 : 155 : s = gfc_dep_compare_expr (start, end);
1742 : : /* Check for an empty range. */
1743 : 155 : if (s == 1)
1744 : : return GFC_DEP_NODEP;
1745 : 155 : if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1746 : : return GFC_DEP_EQUAL;
1747 : : }
1748 : : }
1749 : : /* Negative strides. */
1750 : 0 : else if (s == -1)
1751 : : {
1752 : : /* Check for elem > upper. */
1753 : 0 : if (end && gfc_dep_compare_expr (elem, start) == 1)
1754 : : return GFC_DEP_NODEP;
1755 : : /* Check for elem < lower. */
1756 : 0 : if (start && gfc_dep_compare_expr (elem, end) == -1)
1757 : : return GFC_DEP_NODEP;
1758 : :
1759 : 0 : if (start && end)
1760 : : {
1761 : 0 : s = gfc_dep_compare_expr (start, end);
1762 : : /* Check for an empty range. */
1763 : 0 : if (s == -1)
1764 : : return GFC_DEP_NODEP;
1765 : 0 : if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1766 : : return GFC_DEP_EQUAL;
1767 : : }
1768 : : }
1769 : : /* Unknown strides. */
1770 : : else
1771 : : {
1772 : 0 : if (!start || !end)
1773 : : return GFC_DEP_OVERLAP;
1774 : 0 : s = gfc_dep_compare_expr (start, end);
1775 : 0 : if (s <= -2)
1776 : : return GFC_DEP_OVERLAP;
1777 : : /* Assume positive stride. */
1778 : 0 : if (s == -1)
1779 : : {
1780 : : /* Check for elem < lower. */
1781 : 0 : if (gfc_dep_compare_expr (elem, start) == -1)
1782 : : return GFC_DEP_NODEP;
1783 : : /* Check for elem > upper. */
1784 : 0 : if (gfc_dep_compare_expr (elem, end) == 1)
1785 : : return GFC_DEP_NODEP;
1786 : : }
1787 : : /* Assume negative stride. */
1788 : 0 : else if (s == 1)
1789 : : {
1790 : : /* Check for elem > upper. */
1791 : 0 : if (gfc_dep_compare_expr (elem, start) == 1)
1792 : : return GFC_DEP_NODEP;
1793 : : /* Check for elem < lower. */
1794 : 0 : if (gfc_dep_compare_expr (elem, end) == -1)
1795 : : return GFC_DEP_NODEP;
1796 : : }
1797 : : /* Equal bounds. */
1798 : 0 : else if (s == 0)
1799 : : {
1800 : 0 : s = gfc_dep_compare_expr (elem, start);
1801 : 0 : if (s == 0)
1802 : : return GFC_DEP_EQUAL;
1803 : 0 : if (s == 1 || s == -1)
1804 : : return GFC_DEP_NODEP;
1805 : : }
1806 : : }
1807 : :
1808 : : return GFC_DEP_OVERLAP;
1809 : : }
1810 : :
1811 : :
1812 : : /* Traverse expr, checking all EXPR_VARIABLE symbols for their
1813 : : forall_index attribute. Return true if any variable may be
1814 : : being used as a FORALL index. Its safe to pessimistically
1815 : : return true, and assume a dependency. */
1816 : :
1817 : : static bool
1818 : 6505 : contains_forall_index_p (gfc_expr *expr)
1819 : : {
1820 : 6505 : gfc_actual_arglist *arg;
1821 : 6505 : gfc_constructor *c;
1822 : 6505 : gfc_ref *ref;
1823 : 6505 : int i;
1824 : :
1825 : 6505 : if (!expr)
1826 : : return false;
1827 : :
1828 : 6505 : switch (expr->expr_type)
1829 : : {
1830 : 3264 : case EXPR_VARIABLE:
1831 : 3264 : if (expr->symtree->n.sym->forall_index)
1832 : : return true;
1833 : : break;
1834 : :
1835 : 1492 : case EXPR_OP:
1836 : 1492 : if (contains_forall_index_p (expr->value.op.op1)
1837 : 1492 : || contains_forall_index_p (expr->value.op.op2))
1838 : 7 : return true;
1839 : : break;
1840 : :
1841 : 0 : case EXPR_FUNCTION:
1842 : 0 : for (arg = expr->value.function.actual; arg; arg = arg->next)
1843 : 0 : if (contains_forall_index_p (arg->expr))
1844 : : return true;
1845 : : break;
1846 : :
1847 : : case EXPR_CONSTANT:
1848 : : case EXPR_NULL:
1849 : : case EXPR_SUBSTRING:
1850 : : break;
1851 : :
1852 : 0 : case EXPR_STRUCTURE:
1853 : 0 : case EXPR_ARRAY:
1854 : 0 : for (c = gfc_constructor_first (expr->value.constructor);
1855 : 0 : c; gfc_constructor_next (c))
1856 : 0 : if (contains_forall_index_p (c->expr))
1857 : : return true;
1858 : : break;
1859 : :
1860 : 0 : default:
1861 : 0 : gcc_unreachable ();
1862 : : }
1863 : :
1864 : 6265 : for (ref = expr->ref; ref; ref = ref->next)
1865 : 6 : switch (ref->type)
1866 : : {
1867 : : case REF_ARRAY:
1868 : 6 : for (i = 0; i < ref->u.ar.dimen; i++)
1869 : 6 : if (contains_forall_index_p (ref->u.ar.start[i])
1870 : 0 : || contains_forall_index_p (ref->u.ar.end[i])
1871 : 6 : || contains_forall_index_p (ref->u.ar.stride[i]))
1872 : 6 : return true;
1873 : : break;
1874 : :
1875 : : case REF_COMPONENT:
1876 : : break;
1877 : :
1878 : 0 : case REF_SUBSTRING:
1879 : 0 : if (contains_forall_index_p (ref->u.ss.start)
1880 : 0 : || contains_forall_index_p (ref->u.ss.end))
1881 : 0 : return true;
1882 : : break;
1883 : :
1884 : 0 : default:
1885 : 0 : gcc_unreachable ();
1886 : : }
1887 : :
1888 : : return false;
1889 : : }
1890 : :
1891 : : /* Determines overlapping for two single element array references. */
1892 : :
1893 : : static gfc_dependency
1894 : 2271 : gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1895 : : {
1896 : 2271 : gfc_array_ref l_ar;
1897 : 2271 : gfc_array_ref r_ar;
1898 : 2271 : gfc_expr *l_start;
1899 : 2271 : gfc_expr *r_start;
1900 : 2271 : int i;
1901 : :
1902 : 2271 : l_ar = lref->u.ar;
1903 : 2271 : r_ar = rref->u.ar;
1904 : 2271 : l_start = l_ar.start[n] ;
1905 : 2271 : r_start = r_ar.start[n] ;
1906 : 2271 : i = gfc_dep_compare_expr (r_start, l_start);
1907 : 2271 : if (i == 0)
1908 : : return GFC_DEP_EQUAL;
1909 : :
1910 : : /* Treat two scalar variables as potentially equal. This allows
1911 : : us to prove that a(i,:) and a(j,:) have no dependency. See
1912 : : Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1913 : : Proceedings of the International Conference on Parallel and
1914 : : Distributed Processing Techniques and Applications (PDPTA2001),
1915 : : Las Vegas, Nevada, June 2001. */
1916 : : /* However, we need to be careful when either scalar expression
1917 : : contains a FORALL index, as these can potentially change value
1918 : : during the scalarization/traversal of this array reference. */
1919 : 1874 : if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1920 : 233 : return GFC_DEP_OVERLAP;
1921 : :
1922 : 1641 : if (i > -2)
1923 : : return GFC_DEP_NODEP;
1924 : :
1925 : : return GFC_DEP_EQUAL;
1926 : : }
1927 : :
1928 : : /* Callback function for checking if an expression depends on a
1929 : : dummy variable which is any other than INTENT(IN). */
1930 : :
1931 : : static int
1932 : 4800 : callback_dummy_intent_not_in (gfc_expr **ep,
1933 : : int *walk_subtrees ATTRIBUTE_UNUSED,
1934 : : void *data ATTRIBUTE_UNUSED)
1935 : : {
1936 : 4800 : gfc_expr *e = *ep;
1937 : :
1938 : 4800 : if (e->expr_type == EXPR_VARIABLE && e->symtree
1939 : 177 : && e->symtree->n.sym->attr.dummy)
1940 : 159 : return e->symtree->n.sym->attr.intent != INTENT_IN;
1941 : : else
1942 : : return 0;
1943 : : }
1944 : :
1945 : : /* Auxiliary function to check if subexpressions have dummy variables which
1946 : : are not intent(in).
1947 : : */
1948 : :
1949 : : static bool
1950 : 4575 : dummy_intent_not_in (gfc_expr **ep)
1951 : : {
1952 : 0 : return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL);
1953 : : }
1954 : :
1955 : : /* Determine if an array ref, usually an array section specifies the
1956 : : entire array. In addition, if the second, pointer argument is
1957 : : provided, the function will return true if the reference is
1958 : : contiguous; eg. (:, 1) gives true but (1,:) gives false.
1959 : : If one of the bounds depends on a dummy variable which is
1960 : : not INTENT(IN), also return false, because the user may
1961 : : have changed the variable. */
1962 : :
1963 : : bool
1964 : 173800 : gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1965 : : {
1966 : 173800 : int i;
1967 : 173800 : int n;
1968 : 173800 : bool lbound_OK = true;
1969 : 173800 : bool ubound_OK = true;
1970 : :
1971 : 173800 : if (contiguous)
1972 : 50445 : *contiguous = false;
1973 : :
1974 : 173800 : if (ref->type != REF_ARRAY)
1975 : : return false;
1976 : :
1977 : 173794 : if (ref->u.ar.type == AR_FULL)
1978 : : {
1979 : 125260 : if (contiguous)
1980 : 39867 : *contiguous = true;
1981 : 125260 : return true;
1982 : : }
1983 : :
1984 : 48534 : if (ref->u.ar.type != AR_SECTION)
1985 : : return false;
1986 : 32860 : if (ref->next)
1987 : : return false;
1988 : :
1989 : 63443 : for (i = 0; i < ref->u.ar.dimen; i++)
1990 : : {
1991 : : /* If we have a single element in the reference, for the reference
1992 : : to be full, we need to ascertain that the array has a single
1993 : : element in this dimension and that we actually reference the
1994 : : correct element. */
1995 : 46327 : if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1996 : : {
1997 : : /* This is unconditionally a contiguous reference if all the
1998 : : remaining dimensions are elements. */
1999 : 3327 : if (contiguous)
2000 : : {
2001 : 235 : *contiguous = true;
2002 : 408 : for (n = i + 1; n < ref->u.ar.dimen; n++)
2003 : 173 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2004 : 157 : *contiguous = false;
2005 : : }
2006 : :
2007 : 3358 : if (!ref->u.ar.as
2008 : 3327 : || !ref->u.ar.as->lower[i]
2009 : 2828 : || !ref->u.ar.as->upper[i]
2010 : 2743 : || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
2011 : : ref->u.ar.as->upper[i])
2012 : 31 : || !ref->u.ar.start[i]
2013 : 3358 : || gfc_dep_compare_expr (ref->u.ar.start[i],
2014 : 31 : ref->u.ar.as->lower[i]))
2015 : 3296 : return false;
2016 : : else
2017 : 31 : continue;
2018 : : }
2019 : :
2020 : : /* Check the lower bound. */
2021 : 43000 : if (ref->u.ar.start[i]
2022 : 43000 : && (!ref->u.ar.as
2023 : 11615 : || !ref->u.ar.as->lower[i]
2024 : 7418 : || gfc_dep_compare_expr (ref->u.ar.start[i],
2025 : : ref->u.ar.as->lower[i])
2026 : 3009 : || dummy_intent_not_in (&ref->u.ar.start[i])))
2027 : : lbound_OK = false;
2028 : : /* Check the upper bound. */
2029 : 43000 : if (ref->u.ar.end[i]
2030 : 43000 : && (!ref->u.ar.as
2031 : 11446 : || !ref->u.ar.as->upper[i]
2032 : 6994 : || gfc_dep_compare_expr (ref->u.ar.end[i],
2033 : : ref->u.ar.as->upper[i])
2034 : 1566 : || dummy_intent_not_in (&ref->u.ar.end[i])))
2035 : : ubound_OK = false;
2036 : : /* Check the stride. */
2037 : 43000 : if (ref->u.ar.stride[i]
2038 : 43000 : && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2039 : : return false;
2040 : :
2041 : : /* This is unconditionally a contiguous reference as long as all
2042 : : the subsequent dimensions are elements. */
2043 : 40198 : if (contiguous)
2044 : : {
2045 : 17135 : *contiguous = true;
2046 : 29405 : for (n = i + 1; n < ref->u.ar.dimen; n++)
2047 : 12270 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2048 : 12110 : *contiguous = false;
2049 : : }
2050 : :
2051 : 40198 : if (!lbound_OK || !ubound_OK)
2052 : : return false;
2053 : : }
2054 : : return true;
2055 : : }
2056 : :
2057 : :
2058 : : /* Determine if a full array is the same as an array section with one
2059 : : variable limit. For this to be so, the strides must both be unity
2060 : : and one of either start == lower or end == upper must be true. */
2061 : :
2062 : : static bool
2063 : 12483 : ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
2064 : : {
2065 : 12483 : int i;
2066 : 12483 : bool upper_or_lower;
2067 : :
2068 : 12483 : if (full_ref->type != REF_ARRAY)
2069 : : return false;
2070 : 12483 : if (full_ref->u.ar.type != AR_FULL)
2071 : : return false;
2072 : 4617 : if (ref->type != REF_ARRAY)
2073 : : return false;
2074 : 4617 : if (ref->u.ar.type == AR_FULL)
2075 : : return true;
2076 : 766 : if (ref->u.ar.type != AR_SECTION)
2077 : : return false;
2078 : :
2079 : 647 : for (i = 0; i < ref->u.ar.dimen; i++)
2080 : : {
2081 : : /* If we have a single element in the reference, we need to check
2082 : : that the array has a single element and that we actually reference
2083 : : the correct element. */
2084 : 615 : if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
2085 : : {
2086 : 13 : if (!full_ref->u.ar.as
2087 : 13 : || !full_ref->u.ar.as->lower[i]
2088 : 13 : || !full_ref->u.ar.as->upper[i]
2089 : 13 : || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
2090 : : full_ref->u.ar.as->upper[i])
2091 : 0 : || !ref->u.ar.start[i]
2092 : 13 : || gfc_dep_compare_expr (ref->u.ar.start[i],
2093 : 0 : full_ref->u.ar.as->lower[i]))
2094 : 13 : return false;
2095 : : }
2096 : :
2097 : : /* Check the strides. */
2098 : 602 : if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
2099 : : return false;
2100 : 602 : if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
2101 : : return false;
2102 : :
2103 : 513 : upper_or_lower = false;
2104 : : /* Check the lower bound. */
2105 : 513 : if (ref->u.ar.start[i]
2106 : 513 : && (ref->u.ar.as
2107 : 278 : && full_ref->u.ar.as->lower[i]
2108 : 68 : && gfc_dep_compare_expr (ref->u.ar.start[i],
2109 : : full_ref->u.ar.as->lower[i]) == 0))
2110 : : upper_or_lower = true;
2111 : : /* Check the upper bound. */
2112 : 513 : if (ref->u.ar.end[i]
2113 : 513 : && (ref->u.ar.as
2114 : 227 : && full_ref->u.ar.as->upper[i]
2115 : 61 : && gfc_dep_compare_expr (ref->u.ar.end[i],
2116 : : full_ref->u.ar.as->upper[i]) == 0))
2117 : : upper_or_lower = true;
2118 : 508 : if (!upper_or_lower)
2119 : : return false;
2120 : : }
2121 : : return true;
2122 : : }
2123 : :
2124 : :
2125 : : /* Finds if two array references are overlapping or not.
2126 : : Return value
2127 : : 1 : array references are overlapping, or identical is true and
2128 : : there is some kind of overlap.
2129 : : 0 : array references are identical or not overlapping. */
2130 : :
2131 : : bool
2132 : 7759 : gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse,
2133 : : bool identical)
2134 : : {
2135 : 7759 : int n;
2136 : 7759 : int m;
2137 : 7759 : gfc_dependency fin_dep;
2138 : 7759 : gfc_dependency this_dep;
2139 : 7759 : bool same_component = false;
2140 : :
2141 : 7759 : this_dep = GFC_DEP_ERROR;
2142 : 7759 : fin_dep = GFC_DEP_ERROR;
2143 : : /* Dependencies due to pointers should already have been identified.
2144 : : We only need to check for overlapping array references. */
2145 : :
2146 : 9734 : while (lref && rref)
2147 : : {
2148 : : /* The refs might come in mixed, one with a _data component and one
2149 : : without. Look at their next reference in order to avoid an
2150 : : ICE. */
2151 : :
2152 : 8306 : if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2153 : 513 : && strcmp (lref->u.c.component->name, "_data") == 0)
2154 : 116 : lref = lref->next;
2155 : :
2156 : 8306 : if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2157 : 475 : && strcmp (rref->u.c.component->name, "_data") == 0)
2158 : 78 : rref = rref->next;
2159 : :
2160 : : /* We're resolving from the same base symbol, so both refs should be
2161 : : the same type. We traverse the reference chain until we find ranges
2162 : : that are not equal. */
2163 : 8306 : gcc_assert (lref->type == rref->type);
2164 : 8306 : switch (lref->type)
2165 : : {
2166 : 397 : case REF_COMPONENT:
2167 : : /* The two ranges can't overlap if they are from different
2168 : : components. */
2169 : 397 : if (lref->u.c.component != rref->u.c.component)
2170 : : return 0;
2171 : :
2172 : : same_component = true;
2173 : : break;
2174 : :
2175 : 104 : case REF_SUBSTRING:
2176 : : /* Substring overlaps are handled by the string assignment code
2177 : : if there is not an underlying dependency. */
2178 : 104 : return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
2179 : :
2180 : 7787 : case REF_ARRAY:
2181 : : /* Coarrays: If there is a coindex, either the image differs and there
2182 : : is no overlap or the image is the same - then the normal analysis
2183 : : applies. Hence, return early if either ref is coindexed and more
2184 : : than one image can exist. */
2185 : 7787 : if (flag_coarray != GFC_FCOARRAY_SINGLE
2186 : 7642 : && ((lref->u.ar.codimen
2187 : 138 : && lref->u.ar.dimen_type[lref->u.ar.dimen]
2188 : : != DIMEN_THIS_IMAGE)
2189 : 7642 : || (rref->u.ar.codimen
2190 : : && lref->u.ar.dimen_type[lref->u.ar.dimen]
2191 : : != DIMEN_THIS_IMAGE)))
2192 : : return 1;
2193 : 7731 : if (lref->u.ar.dimen == 0 || rref->u.ar.dimen == 0)
2194 : : {
2195 : : /* Coindexed scalar coarray with GFC_FCOARRAY_SINGLE. */
2196 : 18 : if (lref->u.ar.dimen || rref->u.ar.dimen)
2197 : : return 1; /* Just to be sure. */
2198 : : fin_dep = GFC_DEP_EQUAL;
2199 : : break;
2200 : : }
2201 : :
2202 : 7713 : if (ref_same_as_full_array (lref, rref))
2203 : : return identical;
2204 : :
2205 : 3850 : if (ref_same_as_full_array (rref, lref))
2206 : : return identical;
2207 : :
2208 : 3830 : if (lref->u.ar.dimen != rref->u.ar.dimen)
2209 : : {
2210 : 0 : if (lref->u.ar.type == AR_FULL)
2211 : 0 : fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
2212 : : : GFC_DEP_OVERLAP;
2213 : 0 : else if (rref->u.ar.type == AR_FULL)
2214 : 0 : fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
2215 : : : GFC_DEP_OVERLAP;
2216 : : else
2217 : : return 1;
2218 : : break;
2219 : : }
2220 : :
2221 : : /* Index for the reverse array. */
2222 : : m = -1;
2223 : 6798 : for (n = 0; n < lref->u.ar.dimen; n++)
2224 : : {
2225 : : /* Handle dependency when either of array reference is vector
2226 : : subscript. There is no dependency if the vector indices
2227 : : are equal or if indices are known to be different in a
2228 : : different dimension. */
2229 : 4689 : if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2230 : 4629 : || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2231 : : {
2232 : 117 : if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2233 : 60 : && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2234 : 177 : && gfc_dep_compare_expr (lref->u.ar.start[n],
2235 : : rref->u.ar.start[n]) == 0)
2236 : : this_dep = GFC_DEP_EQUAL;
2237 : : else
2238 : : this_dep = GFC_DEP_OVERLAP;
2239 : :
2240 : 117 : goto update_fin_dep;
2241 : : }
2242 : :
2243 : 4572 : if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2244 : 2219 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2245 : 2071 : this_dep = check_section_vs_section (&lref->u.ar,
2246 : : &rref->u.ar, n);
2247 : 2501 : else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2248 : 2353 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2249 : 82 : this_dep = gfc_check_element_vs_section (lref, rref, n);
2250 : 2419 : else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2251 : 2419 : && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2252 : 148 : this_dep = gfc_check_element_vs_section (rref, lref, n);
2253 : : else
2254 : : {
2255 : 2271 : gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2256 : : && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
2257 : 2271 : this_dep = gfc_check_element_vs_element (rref, lref, n);
2258 : 2271 : if (identical && this_dep == GFC_DEP_EQUAL)
2259 : : this_dep = GFC_DEP_OVERLAP;
2260 : : }
2261 : :
2262 : : /* If any dimension doesn't overlap, we have no dependency. */
2263 : 4432 : if (this_dep == GFC_DEP_NODEP)
2264 : : return 0;
2265 : :
2266 : : /* Now deal with the loop reversal logic: This only works on
2267 : : ranges and is activated by setting
2268 : : reverse[n] == GFC_ENABLE_REVERSE
2269 : : The ability to reverse or not is set by previous conditions
2270 : : in this dimension. If reversal is not activated, the
2271 : : value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
2272 : :
2273 : : /* Get the indexing right for the scalarizing loop. If this
2274 : : is an element, there is no corresponding loop. */
2275 : 2851 : if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
2276 : 2110 : m++;
2277 : :
2278 : 2851 : if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
2279 : 2045 : && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2280 : : {
2281 : 1963 : if (reverse)
2282 : : {
2283 : : /* Reverse if backward dependence and not inhibited. */
2284 : 746 : if (reverse[m] == GFC_ENABLE_REVERSE
2285 : 694 : && this_dep == GFC_DEP_BACKWARD)
2286 : 86 : reverse[m] = GFC_REVERSE_SET;
2287 : :
2288 : : /* Forward if forward dependence and not inhibited. */
2289 : 746 : if (reverse[m] == GFC_ENABLE_REVERSE
2290 : 608 : && this_dep == GFC_DEP_FORWARD)
2291 : 97 : reverse[m] = GFC_FORWARD_SET;
2292 : :
2293 : : /* Flag up overlap if dependence not compatible with
2294 : : the overall state of the expression. */
2295 : 746 : if (reverse[m] == GFC_REVERSE_SET
2296 : 108 : && this_dep == GFC_DEP_FORWARD)
2297 : : {
2298 : 16 : reverse[m] = GFC_INHIBIT_REVERSE;
2299 : 16 : this_dep = GFC_DEP_OVERLAP;
2300 : : }
2301 : 730 : else if (reverse[m] == GFC_FORWARD_SET
2302 : 103 : && this_dep == GFC_DEP_BACKWARD)
2303 : : {
2304 : 6 : reverse[m] = GFC_INHIBIT_REVERSE;
2305 : 6 : this_dep = GFC_DEP_OVERLAP;
2306 : : }
2307 : : }
2308 : :
2309 : : /* If no intention of reversing or reversing is explicitly
2310 : : inhibited, convert backward dependence to overlap. */
2311 : 1963 : if ((!reverse && this_dep == GFC_DEP_BACKWARD)
2312 : 1816 : || (reverse && reverse[m] == GFC_INHIBIT_REVERSE))
2313 : 2968 : this_dep = GFC_DEP_OVERLAP;
2314 : : }
2315 : :
2316 : : /* Overlap codes are in order of priority. We only need to
2317 : : know the worst one.*/
2318 : :
2319 : 888 : update_fin_dep:
2320 : 2968 : if (identical && this_dep == GFC_DEP_EQUAL)
2321 : 550 : this_dep = GFC_DEP_OVERLAP;
2322 : :
2323 : 2968 : if (this_dep > fin_dep)
2324 : 2129 : fin_dep = this_dep;
2325 : : }
2326 : :
2327 : : /* If this is an equal element, we have to keep going until we find
2328 : : the "real" array reference. */
2329 : 2109 : if (lref->u.ar.type == AR_ELEMENT
2330 : 222 : && rref->u.ar.type == AR_ELEMENT
2331 : 222 : && fin_dep == GFC_DEP_EQUAL)
2332 : : break;
2333 : :
2334 : : /* Exactly matching and forward overlapping ranges don't cause a
2335 : : dependency. */
2336 : 2034 : if (fin_dep < GFC_DEP_BACKWARD && !identical)
2337 : : return 0;
2338 : :
2339 : : /* Keep checking. We only have a dependency if
2340 : : subsequent references also overlap. */
2341 : : break;
2342 : :
2343 : 18 : case REF_INQUIRY:
2344 : 18 : if (lref->u.i != rref->u.i)
2345 : : return 0;
2346 : :
2347 : : break;
2348 : :
2349 : 0 : default:
2350 : 0 : gcc_unreachable ();
2351 : : }
2352 : 1975 : lref = lref->next;
2353 : 1975 : rref = rref->next;
2354 : : }
2355 : :
2356 : : /* Assume the worst if we nest to different depths. */
2357 : 1428 : if (lref || rref)
2358 : : return 1;
2359 : :
2360 : : /* This can result from concatenation of assumed length string components. */
2361 : 1366 : if (same_component && fin_dep == GFC_DEP_ERROR)
2362 : : return 1;
2363 : :
2364 : : /* If we haven't seen any array refs then something went wrong. */
2365 : 1354 : gcc_assert (fin_dep != GFC_DEP_ERROR);
2366 : :
2367 : 1354 : if (identical && fin_dep != GFC_DEP_NODEP)
2368 : : return 1;
2369 : :
2370 : 577 : return fin_dep == GFC_DEP_OVERLAP;
2371 : : }
2372 : :
2373 : : /* Check if two refs are equal, for the purposes of checking if one might be
2374 : : the base of the other for OpenMP (target directives). Derived from
2375 : : gfc_dep_resolver. This function is stricter, e.g. indices arr(i) and
2376 : : arr(j) compare as non-equal. */
2377 : :
2378 : : bool
2379 : 1101 : gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr *rexpr)
2380 : : {
2381 : 1101 : gfc_ref *lref, *rref;
2382 : :
2383 : 1101 : if (lexpr->symtree && rexpr->symtree)
2384 : : {
2385 : : /* See are_identical_variables above. */
2386 : 1101 : if (lexpr->symtree->n.sym->attr.dummy
2387 : 0 : && rexpr->symtree->n.sym->attr.dummy)
2388 : : {
2389 : : /* Dummy arguments: Only check for equal names. */
2390 : 0 : if (lexpr->symtree->n.sym->name != rexpr->symtree->n.sym->name)
2391 : : return false;
2392 : : }
2393 : : else
2394 : : {
2395 : 1101 : if (lexpr->symtree->n.sym != rexpr->symtree->n.sym)
2396 : : return false;
2397 : : }
2398 : : }
2399 : 0 : else if (lexpr->base_expr && rexpr->base_expr)
2400 : : {
2401 : 0 : if (gfc_dep_compare_expr (lexpr->base_expr, rexpr->base_expr) != 0)
2402 : : return false;
2403 : : }
2404 : : else
2405 : : return false;
2406 : :
2407 : 1101 : lref = lexpr->ref;
2408 : 1101 : rref = rexpr->ref;
2409 : :
2410 : 1727 : while (lref && rref)
2411 : : {
2412 : 1441 : gfc_dependency fin_dep = GFC_DEP_EQUAL;
2413 : :
2414 : 1441 : if (lref && lref->type == REF_COMPONENT && lref->u.c.component
2415 : 981 : && strcmp (lref->u.c.component->name, "_data") == 0)
2416 : 0 : lref = lref->next;
2417 : :
2418 : 1441 : if (rref && rref->type == REF_COMPONENT && rref->u.c.component
2419 : 981 : && strcmp (rref->u.c.component->name, "_data") == 0)
2420 : 0 : rref = rref->next;
2421 : :
2422 : 1441 : gcc_assert (lref->type == rref->type);
2423 : :
2424 : 1441 : switch (lref->type)
2425 : : {
2426 : 981 : case REF_COMPONENT:
2427 : 981 : if (lref->u.c.component != rref->u.c.component)
2428 : : return false;
2429 : : break;
2430 : :
2431 : 460 : case REF_ARRAY:
2432 : 460 : if (ref_same_as_full_array (lref, rref))
2433 : : break;
2434 : 460 : if (ref_same_as_full_array (rref, lref))
2435 : : break;
2436 : :
2437 : 460 : if (lref->u.ar.dimen != rref->u.ar.dimen)
2438 : : {
2439 : 0 : if (lref->u.ar.type == AR_FULL
2440 : 0 : && gfc_full_array_ref_p (rref, NULL))
2441 : : break;
2442 : 0 : if (rref->u.ar.type == AR_FULL
2443 : 0 : && gfc_full_array_ref_p (lref, NULL))
2444 : : break;
2445 : 0 : return false;
2446 : : }
2447 : :
2448 : 800 : for (int n = 0; n < lref->u.ar.dimen; n++)
2449 : : {
2450 : 460 : if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
2451 : 0 : && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
2452 : 460 : && gfc_dep_compare_expr (lref->u.ar.start[n],
2453 : : rref->u.ar.start[n]) == 0)
2454 : 0 : continue;
2455 : 460 : if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
2456 : 280 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2457 : 202 : fin_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar,
2458 : : n);
2459 : 258 : else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2460 : 180 : && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
2461 : 0 : fin_dep = gfc_check_element_vs_section (lref, rref, n);
2462 : 258 : else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2463 : 258 : && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
2464 : 78 : fin_dep = gfc_check_element_vs_section (rref, lref, n);
2465 : 180 : else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
2466 : 180 : && rref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
2467 : : {
2468 : 180 : gfc_array_ref l_ar = lref->u.ar;
2469 : 180 : gfc_array_ref r_ar = rref->u.ar;
2470 : 180 : gfc_expr *l_start = l_ar.start[n];
2471 : 180 : gfc_expr *r_start = r_ar.start[n];
2472 : 180 : int i = gfc_dep_compare_expr (r_start, l_start);
2473 : 180 : if (i == 0)
2474 : 60 : fin_dep = GFC_DEP_EQUAL;
2475 : : else
2476 : 120 : return false;
2477 : : }
2478 : : else
2479 : : return false;
2480 : 340 : if (n + 1 < lref->u.ar.dimen
2481 : 0 : && fin_dep != GFC_DEP_EQUAL)
2482 : : return false;
2483 : : }
2484 : :
2485 : 340 : if (fin_dep != GFC_DEP_EQUAL
2486 : 340 : && fin_dep != GFC_DEP_OVERLAP)
2487 : : return false;
2488 : :
2489 : : break;
2490 : :
2491 : 0 : default:
2492 : 0 : gcc_unreachable ();
2493 : : }
2494 : 626 : lref = lref->next;
2495 : 626 : rref = rref->next;
2496 : : }
2497 : :
2498 : : return true;
2499 : : }
2500 : :
2501 : :
2502 : : /* gfc_function_dependency returns true for non-dummy symbols with dependencies
2503 : : on an old-fashioned function result (ie. proc_name = proc_name->result).
2504 : : This is used to ensure that initialization code appears after the function
2505 : : result is treated and that any mutual dependencies between these symbols are
2506 : : respected. */
2507 : :
2508 : : static bool
2509 : 10876 : dependency_fcn (gfc_expr *e, gfc_symbol *sym,
2510 : : int *f ATTRIBUTE_UNUSED)
2511 : : {
2512 : 10876 : if (e == NULL)
2513 : : return false;
2514 : :
2515 : 10876 : if (e && e->expr_type == EXPR_VARIABLE)
2516 : : {
2517 : 3648 : if (e->symtree && e->symtree->n.sym == sym)
2518 : : return true;
2519 : : /* Recurse to see if this symbol is dependent on the function result. If
2520 : : so an indirect dependence exists, which should be handled in the same
2521 : : way as a direct dependence. The recursion is prevented from being
2522 : : infinite by statement order. */
2523 : 3606 : else if (e->symtree && e->symtree->n.sym)
2524 : 3606 : return gfc_function_dependency (e->symtree->n.sym, sym);
2525 : : }
2526 : :
2527 : : return false;
2528 : : }
2529 : :
2530 : :
2531 : : bool
2532 : 69533 : gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
2533 : : {
2534 : 69533 : bool dep = false;
2535 : :
2536 : 69533 : if (proc_name && proc_name->attr.function
2537 : 12290 : && proc_name == proc_name->result
2538 : 9940 : && !(sym->attr.dummy || sym->attr.result))
2539 : : {
2540 : 5263 : if (sym->fn_result_dep)
2541 : : return true;
2542 : :
2543 : 5239 : if (sym->as && sym->as->type == AS_EXPLICIT)
2544 : : {
2545 : 7433 : for (int dim = 0; dim < sym->as->rank; dim++)
2546 : : {
2547 : 3754 : if (sym->as->lower[dim]
2548 : 3754 : && sym->as->lower[dim]->expr_type != EXPR_CONSTANT)
2549 : 21 : dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
2550 : : dependency_fcn, 0);
2551 : 3754 : if (dep)
2552 : : {
2553 : 0 : sym->fn_result_dep = 1;
2554 : 0 : return true;
2555 : : }
2556 : 3754 : if (sym->as->upper[dim]
2557 : 3754 : && sym->as->upper[dim]->expr_type != EXPR_CONSTANT)
2558 : 3595 : dep = gfc_traverse_expr (sym->as->upper[dim], proc_name,
2559 : : dependency_fcn, 0);
2560 : 3754 : if (dep)
2561 : : {
2562 : 42 : sym->fn_result_dep = 1;
2563 : 42 : return true;
2564 : : }
2565 : : }
2566 : : }
2567 : :
2568 : 5197 : if (sym->ts.type == BT_CHARACTER
2569 : 66 : && sym->ts.u.cl && sym->ts.u.cl->length
2570 : 66 : && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
2571 : 32 : dep = gfc_traverse_expr (sym->ts.u.cl->length, proc_name,
2572 : : dependency_fcn, 0);
2573 : 5197 : if (dep)
2574 : : {
2575 : 24 : sym->fn_result_dep = 1;
2576 : 24 : return true;
2577 : : }
2578 : : }
2579 : :
2580 : : return false;
2581 : : }
|
