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