]>
Commit | Line | Data |
---|---|---|
4ee9c684 | 1 | /* Dependency analysis |
1384ae99 | 2 | Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010 |
1a9745d2 | 3 | Free Software Foundation, Inc. |
4ee9c684 | 4 | Contributed by Paul Brook <paul@nowt.org> |
5 | ||
c84b470d | 6 | This file is part of GCC. |
4ee9c684 | 7 | |
c84b470d | 8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
bdabe786 | 10 | Software Foundation; either version 3, or (at your option) any later |
c84b470d | 11 | version. |
4ee9c684 | 12 | |
c84b470d | 13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
4ee9c684 | 17 | |
18 | You should have received a copy of the GNU General Public License | |
bdabe786 | 19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
4ee9c684 | 21 | |
22 | /* dependency.c -- Expression dependency analysis code. */ | |
23 | /* There's probably quite a bit of duplication in this file. We currently | |
24 | have different dependency checking functions for different types | |
25 | if dependencies. Ideally these would probably be merged. */ | |
26 | ||
4ee9c684 | 27 | #include "config.h" |
dca58d21 | 28 | #include "system.h" |
4ee9c684 | 29 | #include "gfortran.h" |
30 | #include "dependency.h" | |
126387b5 | 31 | #include "constructor.h" |
4ee9c684 | 32 | |
33 | /* static declarations */ | |
34 | /* Enums */ | |
35 | enum range {LHS, RHS, MID}; | |
36 | ||
37 | /* Dependency types. These must be in reverse order of priority. */ | |
38 | typedef enum | |
39 | { | |
40 | GFC_DEP_ERROR, | |
41 | GFC_DEP_EQUAL, /* Identical Ranges. */ | |
69b1505f | 42 | GFC_DEP_FORWARD, /* e.g., a(1:3), a(2:4). */ |
4ee9c684 | 43 | GFC_DEP_OVERLAP, /* May overlap in some other way. */ |
44 | GFC_DEP_NODEP /* Distinct ranges. */ | |
45 | } | |
46 | gfc_dependency; | |
47 | ||
48 | /* Macros */ | |
49 | #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) | |
50 | ||
51 | ||
52 | /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or | |
53 | def if the value could not be determined. */ | |
54 | ||
55 | int | |
1a9745d2 | 56 | gfc_expr_is_one (gfc_expr *expr, int def) |
4ee9c684 | 57 | { |
22d678e8 | 58 | gcc_assert (expr != NULL); |
4ee9c684 | 59 | |
60 | if (expr->expr_type != EXPR_CONSTANT) | |
61 | return def; | |
62 | ||
63 | if (expr->ts.type != BT_INTEGER) | |
64 | return def; | |
65 | ||
66 | return mpz_cmp_si (expr->value.integer, 1) == 0; | |
67 | } | |
68 | ||
69 | ||
70 | /* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2, | |
71 | and -2 if the relationship could not be determined. */ | |
72 | ||
73 | int | |
1a9745d2 | 74 | gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) |
4ee9c684 | 75 | { |
4d4677fd | 76 | gfc_actual_arglist *args1; |
77 | gfc_actual_arglist *args2; | |
4ee9c684 | 78 | int i; |
79 | ||
4d4677fd | 80 | if (e1->expr_type == EXPR_OP |
dcb1b019 | 81 | && (e1->value.op.op == INTRINSIC_UPLUS |
82 | || e1->value.op.op == INTRINSIC_PARENTHESES)) | |
4d4677fd | 83 | return gfc_dep_compare_expr (e1->value.op.op1, e2); |
84 | if (e2->expr_type == EXPR_OP | |
dcb1b019 | 85 | && (e2->value.op.op == INTRINSIC_UPLUS |
86 | || e2->value.op.op == INTRINSIC_PARENTHESES)) | |
4d4677fd | 87 | return gfc_dep_compare_expr (e1, e2->value.op.op1); |
88 | ||
dcb1b019 | 89 | if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) |
4d4677fd | 90 | { |
91 | /* Compare X+C vs. X. */ | |
92 | if (e1->value.op.op2->expr_type == EXPR_CONSTANT | |
93 | && e1->value.op.op2->ts.type == BT_INTEGER | |
94 | && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) | |
95 | return mpz_sgn (e1->value.op.op2->value.integer); | |
96 | ||
97 | /* Compare P+Q vs. R+S. */ | |
dcb1b019 | 98 | if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) |
4d4677fd | 99 | { |
100 | int l, r; | |
101 | ||
102 | l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); | |
103 | r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); | |
104 | if (l == 0 && r == 0) | |
105 | return 0; | |
106 | if (l == 0 && r != -2) | |
107 | return r; | |
108 | if (l != -2 && r == 0) | |
109 | return l; | |
110 | if (l == 1 && r == 1) | |
111 | return 1; | |
112 | if (l == -1 && r == -1) | |
113 | return -1; | |
114 | ||
115 | l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2); | |
116 | r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1); | |
117 | if (l == 0 && r == 0) | |
118 | return 0; | |
119 | if (l == 0 && r != -2) | |
120 | return r; | |
121 | if (l != -2 && r == 0) | |
122 | return l; | |
123 | if (l == 1 && r == 1) | |
124 | return 1; | |
125 | if (l == -1 && r == -1) | |
126 | return -1; | |
127 | } | |
128 | } | |
129 | ||
130 | /* Compare X vs. X+C. */ | |
dcb1b019 | 131 | if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) |
4d4677fd | 132 | { |
133 | if (e2->value.op.op2->expr_type == EXPR_CONSTANT | |
134 | && e2->value.op.op2->ts.type == BT_INTEGER | |
135 | && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) | |
136 | return -mpz_sgn (e2->value.op.op2->value.integer); | |
137 | } | |
138 | ||
139 | /* Compare X-C vs. X. */ | |
dcb1b019 | 140 | if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) |
4d4677fd | 141 | { |
142 | if (e1->value.op.op2->expr_type == EXPR_CONSTANT | |
143 | && e1->value.op.op2->ts.type == BT_INTEGER | |
144 | && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) | |
145 | return -mpz_sgn (e1->value.op.op2->value.integer); | |
146 | ||
147 | /* Compare P-Q vs. R-S. */ | |
dcb1b019 | 148 | if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) |
4d4677fd | 149 | { |
150 | int l, r; | |
151 | ||
152 | l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); | |
153 | r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); | |
154 | if (l == 0 && r == 0) | |
155 | return 0; | |
156 | if (l != -2 && r == 0) | |
157 | return l; | |
158 | if (l == 0 && r != -2) | |
159 | return -r; | |
160 | if (l == 1 && r == -1) | |
161 | return 1; | |
162 | if (l == -1 && r == 1) | |
163 | return -1; | |
164 | } | |
165 | } | |
166 | ||
167 | /* Compare X vs. X-C. */ | |
dcb1b019 | 168 | if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) |
4d4677fd | 169 | { |
170 | if (e2->value.op.op2->expr_type == EXPR_CONSTANT | |
171 | && e2->value.op.op2->ts.type == BT_INTEGER | |
172 | && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) | |
173 | return mpz_sgn (e2->value.op.op2->value.integer); | |
174 | } | |
175 | ||
4ee9c684 | 176 | if (e1->expr_type != e2->expr_type) |
177 | return -2; | |
178 | ||
179 | switch (e1->expr_type) | |
180 | { | |
181 | case EXPR_CONSTANT: | |
182 | if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) | |
183 | return -2; | |
184 | ||
185 | i = mpz_cmp (e1->value.integer, e2->value.integer); | |
186 | if (i == 0) | |
187 | return 0; | |
188 | else if (i < 0) | |
189 | return -1; | |
190 | return 1; | |
191 | ||
192 | case EXPR_VARIABLE: | |
193 | if (e1->ref || e2->ref) | |
194 | return -2; | |
195 | if (e1->symtree->n.sym == e2->symtree->n.sym) | |
196 | return 0; | |
197 | return -2; | |
198 | ||
bee621f2 | 199 | case EXPR_OP: |
200 | /* Intrinsic operators are the same if their operands are the same. */ | |
dcb1b019 | 201 | if (e1->value.op.op != e2->value.op.op) |
bee621f2 | 202 | return -2; |
203 | if (e1->value.op.op2 == 0) | |
204 | { | |
205 | i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); | |
206 | return i == 0 ? 0 : -2; | |
207 | } | |
208 | if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0 | |
209 | && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0) | |
210 | return 0; | |
211 | /* TODO Handle commutative binary operators here? */ | |
212 | return -2; | |
213 | ||
214 | case EXPR_FUNCTION: | |
215 | /* We can only compare calls to the same intrinsic function. */ | |
1a9745d2 | 216 | if (e1->value.function.isym == 0 || e2->value.function.isym == 0 |
bee621f2 | 217 | || e1->value.function.isym != e2->value.function.isym) |
218 | return -2; | |
219 | ||
4d4677fd | 220 | args1 = e1->value.function.actual; |
221 | args2 = e2->value.function.actual; | |
222 | ||
bee621f2 | 223 | /* We should list the "constant" intrinsic functions. Those |
224 | without side-effects that provide equal results given equal | |
225 | argument lists. */ | |
55cb4417 | 226 | switch (e1->value.function.isym->id) |
bee621f2 | 227 | { |
228 | case GFC_ISYM_CONVERSION: | |
4d4677fd | 229 | /* Handle integer extensions specially, as __convert_i4_i8 |
230 | is not only "constant" but also "unary" and "increasing". */ | |
231 | if (args1 && !args1->next | |
232 | && args2 && !args2->next | |
233 | && e1->ts.type == BT_INTEGER | |
234 | && args1->expr->ts.type == BT_INTEGER | |
235 | && e1->ts.kind > args1->expr->ts.kind | |
236 | && e2->ts.type == e1->ts.type | |
237 | && e2->ts.kind == e1->ts.kind | |
238 | && args2->expr->ts.type == args1->expr->ts.type | |
239 | && args2->expr->ts.kind == args2->expr->ts.kind) | |
240 | return gfc_dep_compare_expr (args1->expr, args2->expr); | |
241 | break; | |
242 | ||
bee621f2 | 243 | case GFC_ISYM_REAL: |
244 | case GFC_ISYM_LOGICAL: | |
245 | case GFC_ISYM_DBLE: | |
246 | break; | |
247 | ||
248 | default: | |
249 | return -2; | |
250 | } | |
251 | ||
252 | /* Compare the argument lists for equality. */ | |
4d4677fd | 253 | while (args1 && args2) |
254 | { | |
255 | if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0) | |
256 | return -2; | |
257 | args1 = args1->next; | |
258 | args2 = args2->next; | |
259 | } | |
260 | return (args1 || args2) ? -2 : 0; | |
bee621f2 | 261 | |
4ee9c684 | 262 | default: |
263 | return -2; | |
264 | } | |
265 | } | |
266 | ||
267 | ||
268 | /* Returns 1 if the two ranges are the same, 0 if they are not, and def | |
269 | if the results are indeterminate. N is the dimension to compare. */ | |
270 | ||
271 | int | |
1a9745d2 | 272 | gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def) |
4ee9c684 | 273 | { |
274 | gfc_expr *e1; | |
275 | gfc_expr *e2; | |
276 | int i; | |
277 | ||
278 | /* TODO: More sophisticated range comparison. */ | |
22d678e8 | 279 | gcc_assert (ar1 && ar2); |
4ee9c684 | 280 | |
22d678e8 | 281 | gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]); |
4ee9c684 | 282 | |
283 | e1 = ar1->stride[n]; | |
284 | e2 = ar2->stride[n]; | |
285 | /* Check for mismatching strides. A NULL stride means a stride of 1. */ | |
286 | if (e1 && !e2) | |
287 | { | |
288 | i = gfc_expr_is_one (e1, -1); | |
289 | if (i == -1) | |
290 | return def; | |
291 | else if (i == 0) | |
292 | return 0; | |
293 | } | |
294 | else if (e2 && !e1) | |
295 | { | |
296 | i = gfc_expr_is_one (e2, -1); | |
297 | if (i == -1) | |
298 | return def; | |
299 | else if (i == 0) | |
300 | return 0; | |
301 | } | |
302 | else if (e1 && e2) | |
303 | { | |
304 | i = gfc_dep_compare_expr (e1, e2); | |
305 | if (i == -2) | |
306 | return def; | |
307 | else if (i != 0) | |
308 | return 0; | |
309 | } | |
310 | /* The strides match. */ | |
311 | ||
312 | /* Check the range start. */ | |
313 | e1 = ar1->start[n]; | |
314 | e2 = ar2->start[n]; | |
a7455f80 | 315 | if (e1 || e2) |
316 | { | |
317 | /* Use the bound of the array if no bound is specified. */ | |
318 | if (ar1->as && !e1) | |
319 | e1 = ar1->as->lower[n]; | |
4ee9c684 | 320 | |
a7455f80 | 321 | if (ar2->as && !e2) |
322 | e2 = ar2->as->lower[n]; | |
4ee9c684 | 323 | |
a7455f80 | 324 | /* Check we have values for both. */ |
325 | if (!(e1 && e2)) | |
326 | return def; | |
4ee9c684 | 327 | |
a7455f80 | 328 | i = gfc_dep_compare_expr (e1, e2); |
329 | if (i == -2) | |
330 | return def; | |
331 | else if (i != 0) | |
332 | return 0; | |
333 | } | |
4ee9c684 | 334 | |
a7455f80 | 335 | /* Check the range end. */ |
336 | e1 = ar1->end[n]; | |
337 | e2 = ar2->end[n]; | |
338 | if (e1 || e2) | |
339 | { | |
340 | /* Use the bound of the array if no bound is specified. */ | |
341 | if (ar1->as && !e1) | |
342 | e1 = ar1->as->upper[n]; | |
4ee9c684 | 343 | |
a7455f80 | 344 | if (ar2->as && !e2) |
345 | e2 = ar2->as->upper[n]; | |
4ee9c684 | 346 | |
a7455f80 | 347 | /* Check we have values for both. */ |
348 | if (!(e1 && e2)) | |
349 | return def; | |
350 | ||
351 | i = gfc_dep_compare_expr (e1, e2); | |
352 | if (i == -2) | |
353 | return def; | |
354 | else if (i != 0) | |
355 | return 0; | |
356 | } | |
357 | ||
358 | return 1; | |
4ee9c684 | 359 | } |
360 | ||
361 | ||
018ef8b8 | 362 | /* Some array-returning intrinsics can be implemented by reusing the |
22046c26 | 363 | data from one of the array arguments. For example, TRANSPOSE does |
018ef8b8 | 364 | not necessarily need to allocate new data: it can be implemented |
365 | by copying the original array's descriptor and simply swapping the | |
366 | two dimension specifications. | |
367 | ||
368 | If EXPR is a call to such an intrinsic, return the argument | |
369 | whose data can be reused, otherwise return NULL. */ | |
370 | ||
371 | gfc_expr * | |
1a9745d2 | 372 | gfc_get_noncopying_intrinsic_argument (gfc_expr *expr) |
018ef8b8 | 373 | { |
374 | if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym) | |
375 | return NULL; | |
376 | ||
55cb4417 | 377 | switch (expr->value.function.isym->id) |
018ef8b8 | 378 | { |
379 | case GFC_ISYM_TRANSPOSE: | |
380 | return expr->value.function.actual->expr; | |
381 | ||
382 | default: | |
383 | return NULL; | |
384 | } | |
385 | } | |
386 | ||
387 | ||
c99d633f | 388 | /* Return true if the result of reference REF can only be constructed |
389 | using a temporary array. */ | |
390 | ||
391 | bool | |
392 | gfc_ref_needs_temporary_p (gfc_ref *ref) | |
393 | { | |
394 | int n; | |
395 | bool subarray_p; | |
396 | ||
397 | subarray_p = false; | |
398 | for (; ref; ref = ref->next) | |
399 | switch (ref->type) | |
400 | { | |
401 | case REF_ARRAY: | |
402 | /* Vector dimensions are generally not monotonic and must be | |
403 | handled using a temporary. */ | |
404 | if (ref->u.ar.type == AR_SECTION) | |
405 | for (n = 0; n < ref->u.ar.dimen; n++) | |
406 | if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) | |
407 | return true; | |
408 | ||
409 | subarray_p = true; | |
410 | break; | |
411 | ||
412 | case REF_SUBSTRING: | |
413 | /* Within an array reference, character substrings generally | |
414 | need a temporary. Character array strides are expressed as | |
415 | multiples of the element size (consistent with other array | |
416 | types), not in characters. */ | |
417 | return subarray_p; | |
418 | ||
419 | case REF_COMPONENT: | |
420 | break; | |
421 | } | |
422 | ||
423 | return false; | |
424 | } | |
425 | ||
426 | ||
1b922cfc | 427 | int |
0ed083d9 | 428 | gfc_is_data_pointer (gfc_expr *e) |
429 | { | |
430 | gfc_ref *ref; | |
431 | ||
1b922cfc | 432 | if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) |
0ed083d9 | 433 | return 0; |
434 | ||
1b922cfc | 435 | /* No subreference if it is a function */ |
436 | gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref); | |
437 | ||
0ed083d9 | 438 | if (e->symtree->n.sym->attr.pointer) |
439 | return 1; | |
1b922cfc | 440 | |
0ed083d9 | 441 | for (ref = e->ref; ref; ref = ref->next) |
442 | if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) | |
443 | return 1; | |
444 | ||
445 | return 0; | |
446 | } | |
447 | ||
448 | ||
018ef8b8 | 449 | /* Return true if array variable VAR could be passed to the same function |
450 | as argument EXPR without interfering with EXPR. INTENT is the intent | |
451 | of VAR. | |
452 | ||
453 | This is considerably less conservative than other dependencies | |
454 | because many function arguments will already be copied into a | |
455 | temporary. */ | |
456 | ||
457 | static int | |
1a9745d2 | 458 | gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, |
74e83bb9 | 459 | gfc_expr *expr, gfc_dep_check elemental) |
018ef8b8 | 460 | { |
74e83bb9 | 461 | gfc_expr *arg; |
462 | ||
018ef8b8 | 463 | gcc_assert (var->expr_type == EXPR_VARIABLE); |
464 | gcc_assert (var->rank > 0); | |
465 | ||
466 | switch (expr->expr_type) | |
467 | { | |
468 | case EXPR_VARIABLE: | |
74e83bb9 | 469 | /* In case of elemental subroutines, there is no dependency |
470 | between two same-range array references. */ | |
471 | if (gfc_ref_needs_temporary_p (expr->ref) | |
08803898 | 472 | || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) |
74e83bb9 | 473 | { |
9ed3ad48 | 474 | if (elemental == ELEM_DONT_CHECK_VARIABLE) |
74e83bb9 | 475 | { |
9ed3ad48 | 476 | /* Too many false positive with pointers. */ |
477 | if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) | |
478 | { | |
479 | /* Elemental procedures forbid unspecified intents, | |
480 | and we don't check dependencies for INTENT_IN args. */ | |
481 | gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); | |
482 | ||
483 | /* We are told not to check dependencies. | |
484 | We do it, however, and issue a warning in case we find one. | |
485 | If a dependency is found in the case | |
486 | elemental == ELEM_CHECK_VARIABLE, we will generate | |
487 | a temporary, so we don't need to bother the user. */ | |
488 | gfc_warning ("INTENT(%s) actual argument at %L might " | |
489 | "interfere with actual argument at %L.", | |
490 | intent == INTENT_OUT ? "OUT" : "INOUT", | |
491 | &var->where, &expr->where); | |
492 | } | |
74e83bb9 | 493 | return 0; |
494 | } | |
495 | else | |
496 | return 1; | |
497 | } | |
498 | return 0; | |
018ef8b8 | 499 | |
500 | case EXPR_ARRAY: | |
dded0b23 | 501 | return gfc_check_dependency (var, expr, 1); |
018ef8b8 | 502 | |
503 | case EXPR_FUNCTION: | |
74e83bb9 | 504 | if (intent != INTENT_IN && expr->inline_noncopying_intrinsic |
505 | && (arg = gfc_get_noncopying_intrinsic_argument (expr)) | |
506 | && gfc_check_argument_var_dependency (var, intent, arg, elemental)) | |
507 | return 1; | |
508 | if (elemental) | |
509 | { | |
510 | if ((expr->value.function.esym | |
511 | && expr->value.function.esym->attr.elemental) | |
512 | || (expr->value.function.isym | |
513 | && expr->value.function.isym->elemental)) | |
514 | return gfc_check_fncall_dependency (var, intent, NULL, | |
515 | expr->value.function.actual, | |
516 | ELEM_CHECK_VARIABLE); | |
517 | } | |
518 | return 0; | |
519 | ||
520 | case EXPR_OP: | |
521 | /* In case of non-elemental procedures, there is no need to catch | |
522 | dependencies, as we will make a temporary anyway. */ | |
523 | if (elemental) | |
018ef8b8 | 524 | { |
74e83bb9 | 525 | /* If the actual arg EXPR is an expression, we need to catch |
526 | a dependency between variables in EXPR and VAR, | |
527 | an intent((IN)OUT) variable. */ | |
528 | if (expr->value.op.op1 | |
529 | && gfc_check_argument_var_dependency (var, intent, | |
530 | expr->value.op.op1, | |
531 | ELEM_CHECK_VARIABLE)) | |
532 | return 1; | |
533 | else if (expr->value.op.op2 | |
534 | && gfc_check_argument_var_dependency (var, intent, | |
535 | expr->value.op.op2, | |
536 | ELEM_CHECK_VARIABLE)) | |
537 | return 1; | |
018ef8b8 | 538 | } |
539 | return 0; | |
540 | ||
541 | default: | |
542 | return 0; | |
543 | } | |
544 | } | |
545 | ||
546 | ||
547 | /* Like gfc_check_argument_var_dependency, but extended to any | |
548 | array expression OTHER, not just variables. */ | |
549 | ||
550 | static int | |
1a9745d2 | 551 | gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, |
74e83bb9 | 552 | gfc_expr *expr, gfc_dep_check elemental) |
018ef8b8 | 553 | { |
554 | switch (other->expr_type) | |
555 | { | |
556 | case EXPR_VARIABLE: | |
74e83bb9 | 557 | return gfc_check_argument_var_dependency (other, intent, expr, elemental); |
018ef8b8 | 558 | |
559 | case EXPR_FUNCTION: | |
560 | if (other->inline_noncopying_intrinsic) | |
561 | { | |
562 | other = gfc_get_noncopying_intrinsic_argument (other); | |
74e83bb9 | 563 | return gfc_check_argument_dependency (other, INTENT_IN, expr, |
564 | elemental); | |
018ef8b8 | 565 | } |
566 | return 0; | |
567 | ||
568 | default: | |
569 | return 0; | |
570 | } | |
571 | } | |
572 | ||
573 | ||
574 | /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL. | |
575 | FNSYM is the function being called, or NULL if not known. */ | |
4ee9c684 | 576 | |
577 | int | |
1a9745d2 | 578 | gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, |
74e83bb9 | 579 | gfc_symbol *fnsym, gfc_actual_arglist *actual, |
580 | gfc_dep_check elemental) | |
4ee9c684 | 581 | { |
018ef8b8 | 582 | gfc_formal_arglist *formal; |
4ee9c684 | 583 | gfc_expr *expr; |
4ee9c684 | 584 | |
018ef8b8 | 585 | formal = fnsym ? fnsym->formal : NULL; |
586 | for (; actual; actual = actual->next, formal = formal ? formal->next : NULL) | |
4ee9c684 | 587 | { |
588 | expr = actual->expr; | |
589 | ||
590 | /* Skip args which are not present. */ | |
591 | if (!expr) | |
592 | continue; | |
9960dc89 | 593 | |
594 | /* Skip other itself. */ | |
595 | if (expr == other) | |
596 | continue; | |
4ee9c684 | 597 | |
018ef8b8 | 598 | /* Skip intent(in) arguments if OTHER itself is intent(in). */ |
1a9745d2 | 599 | if (formal && intent == INTENT_IN |
018ef8b8 | 600 | && formal->sym->attr.intent == INTENT_IN) |
601 | continue; | |
602 | ||
74e83bb9 | 603 | if (gfc_check_argument_dependency (other, intent, expr, elemental)) |
018ef8b8 | 604 | return 1; |
4ee9c684 | 605 | } |
606 | ||
607 | return 0; | |
608 | } | |
609 | ||
610 | ||
0b5dc8b5 | 611 | /* Return 1 if e1 and e2 are equivalenced arrays, either |
69b1505f | 612 | directly or indirectly; i.e., equivalence (a,b) for a and b |
0b5dc8b5 | 613 | or equivalence (a,c),(b,c). This function uses the equiv_ |
614 | lists, generated in trans-common(add_equivalences), that are | |
78787e4b | 615 | guaranteed to pick up indirect equivalences. We explicitly |
616 | check for overlap using the offset and length of the equivalence. | |
617 | This function is symmetric. | |
618 | TODO: This function only checks whether the full top-level | |
619 | symbols overlap. An improved implementation could inspect | |
620 | e1->ref and e2->ref to determine whether the actually accessed | |
621 | portions of these variables/arrays potentially overlap. */ | |
0b5dc8b5 | 622 | |
623 | int | |
624 | gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) | |
625 | { | |
626 | gfc_equiv_list *l; | |
627 | gfc_equiv_info *s, *fl1, *fl2; | |
628 | ||
629 | gcc_assert (e1->expr_type == EXPR_VARIABLE | |
1a9745d2 | 630 | && e2->expr_type == EXPR_VARIABLE); |
0b5dc8b5 | 631 | |
632 | if (!e1->symtree->n.sym->attr.in_equivalence | |
1a9745d2 | 633 | || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank) |
0b5dc8b5 | 634 | return 0; |
635 | ||
d60fed4c | 636 | if (e1->symtree->n.sym->ns |
637 | && e1->symtree->n.sym->ns != gfc_current_ns) | |
638 | l = e1->symtree->n.sym->ns->equiv_lists; | |
639 | else | |
640 | l = gfc_current_ns->equiv_lists; | |
641 | ||
0b5dc8b5 | 642 | /* Go through the equiv_lists and return 1 if the variables |
643 | e1 and e2 are members of the same group and satisfy the | |
644 | requirement on their relative offsets. */ | |
d60fed4c | 645 | for (; l; l = l->next) |
0b5dc8b5 | 646 | { |
647 | fl1 = NULL; | |
648 | fl2 = NULL; | |
649 | for (s = l->equiv; s; s = s->next) | |
650 | { | |
651 | if (s->sym == e1->symtree->n.sym) | |
78787e4b | 652 | { |
653 | fl1 = s; | |
654 | if (fl2) | |
655 | break; | |
656 | } | |
0b5dc8b5 | 657 | if (s->sym == e2->symtree->n.sym) |
78787e4b | 658 | { |
659 | fl2 = s; | |
660 | if (fl1) | |
661 | break; | |
662 | } | |
663 | } | |
664 | ||
665 | if (s) | |
666 | { | |
667 | /* Can these lengths be zero? */ | |
668 | if (fl1->length <= 0 || fl2->length <= 0) | |
669 | return 1; | |
670 | /* These can't overlap if [f11,fl1+length] is before | |
671 | [fl2,fl2+length], or [fl2,fl2+length] is before | |
672 | [fl1,fl1+length], otherwise they do overlap. */ | |
673 | if (fl1->offset + fl1->length > fl2->offset | |
674 | && fl2->offset + fl2->length > fl1->offset) | |
0b5dc8b5 | 675 | return 1; |
676 | } | |
677 | } | |
78787e4b | 678 | return 0; |
0b5dc8b5 | 679 | } |
680 | ||
681 | ||
08803898 | 682 | /* Return true if there is no possibility of aliasing because of a type |
683 | mismatch between all the possible pointer references and the | |
684 | potential target. Note that this function is asymmetric in the | |
685 | arguments and so must be called twice with the arguments exchanged. */ | |
686 | ||
687 | static bool | |
688 | check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2) | |
689 | { | |
690 | gfc_component *cm1; | |
691 | gfc_symbol *sym1; | |
692 | gfc_symbol *sym2; | |
693 | gfc_ref *ref1; | |
694 | bool seen_component_ref; | |
695 | ||
696 | if (expr1->expr_type != EXPR_VARIABLE | |
697 | || expr1->expr_type != EXPR_VARIABLE) | |
698 | return false; | |
699 | ||
700 | sym1 = expr1->symtree->n.sym; | |
701 | sym2 = expr2->symtree->n.sym; | |
702 | ||
703 | /* Keep it simple for now. */ | |
704 | if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED) | |
705 | return false; | |
706 | ||
707 | if (sym1->attr.pointer) | |
708 | { | |
709 | if (gfc_compare_types (&sym1->ts, &sym2->ts)) | |
710 | return false; | |
711 | } | |
712 | ||
713 | /* This is a conservative check on the components of the derived type | |
714 | if no component references have been seen. Since we will not dig | |
715 | into the components of derived type components, we play it safe by | |
716 | returning false. First we check the reference chain and then, if | |
717 | no component references have been seen, the components. */ | |
718 | seen_component_ref = false; | |
719 | if (sym1->ts.type == BT_DERIVED) | |
720 | { | |
721 | for (ref1 = expr1->ref; ref1; ref1 = ref1->next) | |
722 | { | |
723 | if (ref1->type != REF_COMPONENT) | |
724 | continue; | |
725 | ||
726 | if (ref1->u.c.component->ts.type == BT_DERIVED) | |
727 | return false; | |
728 | ||
729 | if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) | |
730 | && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) | |
731 | return false; | |
732 | ||
733 | seen_component_ref = true; | |
734 | } | |
735 | } | |
736 | ||
737 | if (sym1->ts.type == BT_DERIVED && !seen_component_ref) | |
738 | { | |
739 | for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next) | |
740 | { | |
741 | if (cm1->ts.type == BT_DERIVED) | |
742 | return false; | |
743 | ||
744 | if ((sym2->attr.pointer || cm1->attr.pointer) | |
745 | && gfc_compare_types (&cm1->ts, &sym2->ts)) | |
746 | return false; | |
747 | } | |
748 | } | |
749 | ||
750 | return true; | |
751 | } | |
752 | ||
753 | ||
4ee9c684 | 754 | /* Return true if the statement body redefines the condition. Returns |
755 | true if expr2 depends on expr1. expr1 should be a single term | |
dded0b23 | 756 | suitable for the lhs of an assignment. The IDENTICAL flag indicates |
757 | whether array references to the same symbol with identical range | |
758 | references count as a dependency or not. Used for forall and where | |
4ee9c684 | 759 | statements. Also used with functions returning arrays without a |
760 | temporary. */ | |
761 | ||
762 | int | |
1a9745d2 | 763 | gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) |
4ee9c684 | 764 | { |
c5918475 | 765 | gfc_actual_arglist *actual; |
766 | gfc_constructor *c; | |
4ee9c684 | 767 | int n; |
4ee9c684 | 768 | |
22d678e8 | 769 | gcc_assert (expr1->expr_type == EXPR_VARIABLE); |
4ee9c684 | 770 | |
4ee9c684 | 771 | switch (expr2->expr_type) |
772 | { | |
773 | case EXPR_OP: | |
dded0b23 | 774 | n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); |
4ee9c684 | 775 | if (n) |
776 | return n; | |
9b773341 | 777 | if (expr2->value.op.op2) |
dded0b23 | 778 | return gfc_check_dependency (expr1, expr2->value.op.op2, identical); |
4ee9c684 | 779 | return 0; |
780 | ||
781 | case EXPR_VARIABLE: | |
e33c5890 | 782 | /* The interesting cases are when the symbols don't match. */ |
783 | if (expr1->symtree->n.sym != expr2->symtree->n.sym) | |
4ee9c684 | 784 | { |
e33c5890 | 785 | gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; |
786 | gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; | |
787 | ||
788 | /* Return 1 if expr1 and expr2 are equivalenced arrays. */ | |
789 | if (gfc_are_equivalenced_arrays (expr1, expr2)) | |
4ee9c684 | 790 | return 1; |
4ee9c684 | 791 | |
e33c5890 | 792 | /* Symbols can only alias if they have the same type. */ |
1a9745d2 | 793 | if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN |
794 | && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) | |
e33c5890 | 795 | { |
1a9745d2 | 796 | if (ts1->type != ts2->type || ts1->kind != ts2->kind) |
e33c5890 | 797 | return 0; |
798 | } | |
0b5dc8b5 | 799 | |
e33c5890 | 800 | /* If either variable is a pointer, assume the worst. */ |
801 | /* TODO: -fassume-no-pointer-aliasing */ | |
0ed083d9 | 802 | if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2)) |
08803898 | 803 | { |
804 | if (check_data_pointer_types (expr1, expr2) | |
805 | && check_data_pointer_types (expr2, expr1)) | |
806 | return 0; | |
807 | ||
808 | return 1; | |
809 | } | |
e33c5890 | 810 | |
811 | /* Otherwise distinct symbols have no dependencies. */ | |
812 | return 0; | |
813 | } | |
4ee9c684 | 814 | |
dded0b23 | 815 | if (identical) |
816 | return 1; | |
817 | ||
80425127 | 818 | /* Identical and disjoint ranges return 0, |
819 | overlapping ranges return 1. */ | |
791d4123 | 820 | if (expr1->ref && expr2->ref) |
80425127 | 821 | return gfc_dep_resolver (expr1->ref, expr2->ref); |
dded0b23 | 822 | |
4ee9c684 | 823 | return 1; |
824 | ||
825 | case EXPR_FUNCTION: | |
dded0b23 | 826 | if (expr2->inline_noncopying_intrinsic) |
827 | identical = 1; | |
231e961a | 828 | /* Remember possible differences between elemental and |
a7455f80 | 829 | transformational functions. All functions inside a FORALL |
830 | will be pure. */ | |
4ee9c684 | 831 | for (actual = expr2->value.function.actual; |
832 | actual; actual = actual->next) | |
833 | { | |
834 | if (!actual->expr) | |
835 | continue; | |
dded0b23 | 836 | n = gfc_check_dependency (expr1, actual->expr, identical); |
4ee9c684 | 837 | if (n) |
838 | return n; | |
839 | } | |
840 | return 0; | |
841 | ||
842 | case EXPR_CONSTANT: | |
11c3ed2a | 843 | case EXPR_NULL: |
4ee9c684 | 844 | return 0; |
845 | ||
846 | case EXPR_ARRAY: | |
c5918475 | 847 | /* Loop through the array constructor's elements. */ |
126387b5 | 848 | for (c = gfc_constructor_first (expr2->value.constructor); |
849 | c; c = gfc_constructor_next (c)) | |
c5918475 | 850 | { |
851 | /* If this is an iterator, assume the worst. */ | |
852 | if (c->iterator) | |
853 | return 1; | |
854 | /* Avoid recursion in the common case. */ | |
855 | if (c->expr->expr_type == EXPR_CONSTANT) | |
856 | continue; | |
857 | if (gfc_check_dependency (expr1, c->expr, 1)) | |
858 | return 1; | |
859 | } | |
860 | return 0; | |
4ee9c684 | 861 | |
862 | default: | |
863 | return 1; | |
864 | } | |
865 | } | |
866 | ||
867 | ||
4ee9c684 | 868 | /* Determines overlapping for two array sections. */ |
869 | ||
870 | static gfc_dependency | |
1a9745d2 | 871 | gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n) |
4ee9c684 | 872 | { |
3f4feb44 | 873 | gfc_array_ref l_ar; |
4ee9c684 | 874 | gfc_expr *l_start; |
875 | gfc_expr *l_end; | |
876 | gfc_expr *l_stride; | |
3f4feb44 | 877 | gfc_expr *l_lower; |
878 | gfc_expr *l_upper; | |
879 | int l_dir; | |
4ee9c684 | 880 | |
3f4feb44 | 881 | gfc_array_ref r_ar; |
4ee9c684 | 882 | gfc_expr *r_start; |
3f4feb44 | 883 | gfc_expr *r_end; |
4ee9c684 | 884 | gfc_expr *r_stride; |
3f4feb44 | 885 | gfc_expr *r_lower; |
886 | gfc_expr *r_upper; | |
887 | int r_dir; | |
4ee9c684 | 888 | |
889 | l_ar = lref->u.ar; | |
890 | r_ar = rref->u.ar; | |
477c2f87 | 891 | |
892 | /* If they are the same range, return without more ado. */ | |
893 | if (gfc_is_same_range (&l_ar, &r_ar, n, 0)) | |
894 | return GFC_DEP_EQUAL; | |
4ee9c684 | 895 | |
896 | l_start = l_ar.start[n]; | |
897 | l_end = l_ar.end[n]; | |
898 | l_stride = l_ar.stride[n]; | |
3f4feb44 | 899 | |
4ee9c684 | 900 | r_start = r_ar.start[n]; |
3f4feb44 | 901 | r_end = r_ar.end[n]; |
4ee9c684 | 902 | r_stride = r_ar.stride[n]; |
903 | ||
3f4feb44 | 904 | /* If l_start is NULL take it from array specifier. */ |
905 | if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as)) | |
4ee9c684 | 906 | l_start = l_ar.as->lower[n]; |
3f4feb44 | 907 | /* If l_end is NULL take it from array specifier. */ |
908 | if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as)) | |
4ee9c684 | 909 | l_end = l_ar.as->upper[n]; |
910 | ||
3f4feb44 | 911 | /* If r_start is NULL take it from array specifier. */ |
912 | if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as)) | |
4ee9c684 | 913 | r_start = r_ar.as->lower[n]; |
3f4feb44 | 914 | /* If r_end is NULL take it from array specifier. */ |
915 | if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as)) | |
916 | r_end = r_ar.as->upper[n]; | |
917 | ||
918 | /* Determine whether the l_stride is positive or negative. */ | |
919 | if (!l_stride) | |
920 | l_dir = 1; | |
921 | else if (l_stride->expr_type == EXPR_CONSTANT | |
1a9745d2 | 922 | && l_stride->ts.type == BT_INTEGER) |
3f4feb44 | 923 | l_dir = mpz_sgn (l_stride->value.integer); |
924 | else if (l_start && l_end) | |
925 | l_dir = gfc_dep_compare_expr (l_end, l_start); | |
926 | else | |
927 | l_dir = -2; | |
928 | ||
929 | /* Determine whether the r_stride is positive or negative. */ | |
930 | if (!r_stride) | |
931 | r_dir = 1; | |
932 | else if (r_stride->expr_type == EXPR_CONSTANT | |
1a9745d2 | 933 | && r_stride->ts.type == BT_INTEGER) |
3f4feb44 | 934 | r_dir = mpz_sgn (r_stride->value.integer); |
935 | else if (r_start && r_end) | |
936 | r_dir = gfc_dep_compare_expr (r_end, r_start); | |
937 | else | |
938 | r_dir = -2; | |
4ee9c684 | 939 | |
3f4feb44 | 940 | /* The strides should never be zero. */ |
941 | if (l_dir == 0 || r_dir == 0) | |
942 | return GFC_DEP_OVERLAP; | |
4ee9c684 | 943 | |
3f4feb44 | 944 | /* Determine LHS upper and lower bounds. */ |
945 | if (l_dir == 1) | |
946 | { | |
947 | l_lower = l_start; | |
948 | l_upper = l_end; | |
949 | } | |
950 | else if (l_dir == -1) | |
951 | { | |
952 | l_lower = l_end; | |
953 | l_upper = l_start; | |
954 | } | |
4ee9c684 | 955 | else |
3f4feb44 | 956 | { |
957 | l_lower = NULL; | |
958 | l_upper = NULL; | |
959 | } | |
4ee9c684 | 960 | |
3f4feb44 | 961 | /* Determine RHS upper and lower bounds. */ |
962 | if (r_dir == 1) | |
963 | { | |
964 | r_lower = r_start; | |
965 | r_upper = r_end; | |
966 | } | |
967 | else if (r_dir == -1) | |
968 | { | |
969 | r_lower = r_end; | |
970 | r_upper = r_start; | |
971 | } | |
972 | else | |
973 | { | |
974 | r_lower = NULL; | |
975 | r_upper = NULL; | |
976 | } | |
977 | ||
978 | /* Check whether the ranges are disjoint. */ | |
979 | if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1) | |
980 | return GFC_DEP_NODEP; | |
981 | if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1) | |
982 | return GFC_DEP_NODEP; | |
983 | ||
984 | /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */ | |
985 | if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0) | |
986 | { | |
987 | if (l_dir == 1 && r_dir == -1) | |
1a9745d2 | 988 | return GFC_DEP_EQUAL; |
3f4feb44 | 989 | if (l_dir == -1 && r_dir == 1) |
1a9745d2 | 990 | return GFC_DEP_EQUAL; |
3f4feb44 | 991 | } |
992 | ||
993 | /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */ | |
994 | if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0) | |
995 | { | |
996 | if (l_dir == 1 && r_dir == -1) | |
1a9745d2 | 997 | return GFC_DEP_EQUAL; |
3f4feb44 | 998 | if (l_dir == -1 && r_dir == 1) |
1a9745d2 | 999 | return GFC_DEP_EQUAL; |
3f4feb44 | 1000 | } |
1001 | ||
1002 | /* Check for forward dependencies x:y vs. x+1:z. */ | |
1003 | if (l_dir == 1 && r_dir == 1 | |
1004 | && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1 | |
1005 | && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1) | |
1006 | { | |
1007 | /* Check that the strides are the same. */ | |
1008 | if (!l_stride && !r_stride) | |
1009 | return GFC_DEP_FORWARD; | |
1010 | if (l_stride && r_stride | |
1011 | && gfc_dep_compare_expr (l_stride, r_stride) == 0) | |
1012 | return GFC_DEP_FORWARD; | |
1013 | } | |
1014 | ||
1015 | /* Check for forward dependencies x:y:-1 vs. x-1:z:-1. */ | |
1016 | if (l_dir == -1 && r_dir == -1 | |
1017 | && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1 | |
1018 | && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1) | |
1019 | { | |
1020 | /* Check that the strides are the same. */ | |
1021 | if (!l_stride && !r_stride) | |
1022 | return GFC_DEP_FORWARD; | |
1023 | if (l_stride && r_stride | |
1024 | && gfc_dep_compare_expr (l_stride, r_stride) == 0) | |
1025 | return GFC_DEP_FORWARD; | |
1026 | } | |
1027 | ||
1028 | return GFC_DEP_OVERLAP; | |
4ee9c684 | 1029 | } |
1030 | ||
1031 | ||
a6c8790e | 1032 | /* Determines overlapping for a single element and a section. */ |
4ee9c684 | 1033 | |
1034 | static gfc_dependency | |
1a9745d2 | 1035 | gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n) |
4ee9c684 | 1036 | { |
a6c8790e | 1037 | gfc_array_ref *ref; |
1038 | gfc_expr *elem; | |
1039 | gfc_expr *start; | |
1040 | gfc_expr *end; | |
1041 | gfc_expr *stride; | |
4ee9c684 | 1042 | int s; |
1043 | ||
a6c8790e | 1044 | elem = lref->u.ar.start[n]; |
1045 | if (!elem) | |
4ee9c684 | 1046 | return GFC_DEP_OVERLAP; |
1047 | ||
a6c8790e | 1048 | ref = &rref->u.ar; |
1049 | start = ref->start[n] ; | |
1050 | end = ref->end[n] ; | |
1051 | stride = ref->stride[n]; | |
1052 | ||
1053 | if (!start && IS_ARRAY_EXPLICIT (ref->as)) | |
1054 | start = ref->as->lower[n]; | |
1055 | if (!end && IS_ARRAY_EXPLICIT (ref->as)) | |
1056 | end = ref->as->upper[n]; | |
1057 | ||
1058 | /* Determine whether the stride is positive or negative. */ | |
1059 | if (!stride) | |
1060 | s = 1; | |
1061 | else if (stride->expr_type == EXPR_CONSTANT | |
1062 | && stride->ts.type == BT_INTEGER) | |
1063 | s = mpz_sgn (stride->value.integer); | |
1064 | else | |
1065 | s = -2; | |
4ee9c684 | 1066 | |
a6c8790e | 1067 | /* Stride should never be zero. */ |
1068 | if (s == 0) | |
4ee9c684 | 1069 | return GFC_DEP_OVERLAP; |
1070 | ||
a6c8790e | 1071 | /* Positive strides. */ |
4ee9c684 | 1072 | if (s == 1) |
1073 | { | |
a6c8790e | 1074 | /* Check for elem < lower. */ |
1075 | if (start && gfc_dep_compare_expr (elem, start) == -1) | |
1076 | return GFC_DEP_NODEP; | |
1077 | /* Check for elem > upper. */ | |
1078 | if (end && gfc_dep_compare_expr (elem, end) == 1) | |
1079 | return GFC_DEP_NODEP; | |
1080 | ||
1081 | if (start && end) | |
1082 | { | |
1083 | s = gfc_dep_compare_expr (start, end); | |
1084 | /* Check for an empty range. */ | |
1085 | if (s == 1) | |
1086 | return GFC_DEP_NODEP; | |
1087 | if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) | |
1088 | return GFC_DEP_EQUAL; | |
1089 | } | |
1090 | } | |
1091 | /* Negative strides. */ | |
1092 | else if (s == -1) | |
1093 | { | |
1094 | /* Check for elem > upper. */ | |
1095 | if (end && gfc_dep_compare_expr (elem, start) == 1) | |
1096 | return GFC_DEP_NODEP; | |
1097 | /* Check for elem < lower. */ | |
1098 | if (start && gfc_dep_compare_expr (elem, end) == -1) | |
1099 | return GFC_DEP_NODEP; | |
1100 | ||
1101 | if (start && end) | |
1102 | { | |
1103 | s = gfc_dep_compare_expr (start, end); | |
1104 | /* Check for an empty range. */ | |
1105 | if (s == -1) | |
1106 | return GFC_DEP_NODEP; | |
1107 | if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) | |
1108 | return GFC_DEP_EQUAL; | |
1109 | } | |
4ee9c684 | 1110 | } |
a6c8790e | 1111 | /* Unknown strides. */ |
4ee9c684 | 1112 | else |
1113 | { | |
a6c8790e | 1114 | if (!start || !end) |
1115 | return GFC_DEP_OVERLAP; | |
1116 | s = gfc_dep_compare_expr (start, end); | |
1117 | if (s == -2) | |
4ee9c684 | 1118 | return GFC_DEP_OVERLAP; |
a6c8790e | 1119 | /* Assume positive stride. */ |
1120 | if (s == -1) | |
1121 | { | |
1122 | /* Check for elem < lower. */ | |
1123 | if (gfc_dep_compare_expr (elem, start) == -1) | |
1124 | return GFC_DEP_NODEP; | |
1125 | /* Check for elem > upper. */ | |
1126 | if (gfc_dep_compare_expr (elem, end) == 1) | |
1127 | return GFC_DEP_NODEP; | |
1128 | } | |
1129 | /* Assume negative stride. */ | |
1130 | else if (s == 1) | |
1131 | { | |
1132 | /* Check for elem > upper. */ | |
1133 | if (gfc_dep_compare_expr (elem, start) == 1) | |
1134 | return GFC_DEP_NODEP; | |
1135 | /* Check for elem < lower. */ | |
1136 | if (gfc_dep_compare_expr (elem, end) == -1) | |
1137 | return GFC_DEP_NODEP; | |
1138 | } | |
1139 | /* Equal bounds. */ | |
1140 | else if (s == 0) | |
1141 | { | |
1142 | s = gfc_dep_compare_expr (elem, start); | |
1143 | if (s == 0) | |
1144 | return GFC_DEP_EQUAL; | |
1145 | if (s == 1 || s == -1) | |
1146 | return GFC_DEP_NODEP; | |
1147 | } | |
4ee9c684 | 1148 | } |
4ee9c684 | 1149 | |
a6c8790e | 1150 | return GFC_DEP_OVERLAP; |
4ee9c684 | 1151 | } |
1152 | ||
1153 | ||
bf0a0eb6 | 1154 | /* Traverse expr, checking all EXPR_VARIABLE symbols for their |
1155 | forall_index attribute. Return true if any variable may be | |
1156 | being used as a FORALL index. Its safe to pessimistically | |
1157 | return true, and assume a dependency. */ | |
1158 | ||
1159 | static bool | |
1a9745d2 | 1160 | contains_forall_index_p (gfc_expr *expr) |
bf0a0eb6 | 1161 | { |
1162 | gfc_actual_arglist *arg; | |
1163 | gfc_constructor *c; | |
1164 | gfc_ref *ref; | |
1165 | int i; | |
1166 | ||
1167 | if (!expr) | |
1168 | return false; | |
1169 | ||
1170 | switch (expr->expr_type) | |
1171 | { | |
1172 | case EXPR_VARIABLE: | |
1173 | if (expr->symtree->n.sym->forall_index) | |
1174 | return true; | |
1175 | break; | |
1176 | ||
1177 | case EXPR_OP: | |
1178 | if (contains_forall_index_p (expr->value.op.op1) | |
1179 | || contains_forall_index_p (expr->value.op.op2)) | |
1180 | return true; | |
1181 | break; | |
1182 | ||
1183 | case EXPR_FUNCTION: | |
1184 | for (arg = expr->value.function.actual; arg; arg = arg->next) | |
1185 | if (contains_forall_index_p (arg->expr)) | |
1186 | return true; | |
1187 | break; | |
1188 | ||
1189 | case EXPR_CONSTANT: | |
1190 | case EXPR_NULL: | |
1191 | case EXPR_SUBSTRING: | |
1192 | break; | |
1193 | ||
1194 | case EXPR_STRUCTURE: | |
1195 | case EXPR_ARRAY: | |
126387b5 | 1196 | for (c = gfc_constructor_first (expr->value.constructor); |
1197 | c; gfc_constructor_next (c)) | |
bf0a0eb6 | 1198 | if (contains_forall_index_p (c->expr)) |
1199 | return true; | |
1200 | break; | |
1201 | ||
1202 | default: | |
1203 | gcc_unreachable (); | |
1204 | } | |
1205 | ||
1206 | for (ref = expr->ref; ref; ref = ref->next) | |
1207 | switch (ref->type) | |
1208 | { | |
1209 | case REF_ARRAY: | |
1210 | for (i = 0; i < ref->u.ar.dimen; i++) | |
1211 | if (contains_forall_index_p (ref->u.ar.start[i]) | |
1212 | || contains_forall_index_p (ref->u.ar.end[i]) | |
1213 | || contains_forall_index_p (ref->u.ar.stride[i])) | |
1214 | return true; | |
1215 | break; | |
1216 | ||
1217 | case REF_COMPONENT: | |
1218 | break; | |
1219 | ||
1220 | case REF_SUBSTRING: | |
1221 | if (contains_forall_index_p (ref->u.ss.start) | |
1222 | || contains_forall_index_p (ref->u.ss.end)) | |
1223 | return true; | |
1224 | break; | |
1225 | ||
1226 | default: | |
1227 | gcc_unreachable (); | |
1228 | } | |
1229 | ||
1230 | return false; | |
1231 | } | |
1232 | ||
4ee9c684 | 1233 | /* Determines overlapping for two single element array references. */ |
1234 | ||
1235 | static gfc_dependency | |
1a9745d2 | 1236 | gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n) |
4ee9c684 | 1237 | { |
1238 | gfc_array_ref l_ar; | |
1239 | gfc_array_ref r_ar; | |
1240 | gfc_expr *l_start; | |
1241 | gfc_expr *r_start; | |
80425127 | 1242 | int i; |
4ee9c684 | 1243 | |
80425127 | 1244 | l_ar = lref->u.ar; |
1245 | r_ar = rref->u.ar; | |
1246 | l_start = l_ar.start[n] ; | |
1247 | r_start = r_ar.start[n] ; | |
1248 | i = gfc_dep_compare_expr (r_start, l_start); | |
1249 | if (i == 0) | |
1250 | return GFC_DEP_EQUAL; | |
bf0a0eb6 | 1251 | |
1252 | /* Treat two scalar variables as potentially equal. This allows | |
1253 | us to prove that a(i,:) and a(j,:) have no dependency. See | |
1254 | Gerald Roth, "Evaluation of Array Syntax Dependence Analysis", | |
1255 | Proceedings of the International Conference on Parallel and | |
1256 | Distributed Processing Techniques and Applications (PDPTA2001), | |
1257 | Las Vegas, Nevada, June 2001. */ | |
1258 | /* However, we need to be careful when either scalar expression | |
1259 | contains a FORALL index, as these can potentially change value | |
1260 | during the scalarization/traversal of this array reference. */ | |
1a9745d2 | 1261 | if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start)) |
17c67d08 | 1262 | return GFC_DEP_OVERLAP; |
bf0a0eb6 | 1263 | |
4d4677fd | 1264 | if (i != -2) |
1265 | return GFC_DEP_NODEP; | |
bf0a0eb6 | 1266 | return GFC_DEP_EQUAL; |
4ee9c684 | 1267 | } |
1268 | ||
1269 | ||
eb89ca84 | 1270 | /* Determine if an array ref, usually an array section specifies the |
8d60cc46 | 1271 | entire array. In addition, if the second, pointer argument is |
1272 | provided, the function will return true if the reference is | |
1273 | contiguous; eg. (:, 1) gives true but (1,:) gives false. */ | |
eb89ca84 | 1274 | |
1275 | bool | |
8d60cc46 | 1276 | gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) |
eb89ca84 | 1277 | { |
1278 | int i; | |
9bf78879 | 1279 | int n; |
8d60cc46 | 1280 | bool lbound_OK = true; |
1281 | bool ubound_OK = true; | |
eb89ca84 | 1282 | |
88a37d69 | 1283 | if (contiguous) |
1284 | *contiguous = false; | |
1285 | ||
eb89ca84 | 1286 | if (ref->type != REF_ARRAY) |
1287 | return false; | |
9bf78879 | 1288 | |
eb89ca84 | 1289 | if (ref->u.ar.type == AR_FULL) |
88a37d69 | 1290 | { |
1291 | if (contiguous) | |
1292 | *contiguous = true; | |
1293 | return true; | |
1294 | } | |
9bf78879 | 1295 | |
eb89ca84 | 1296 | if (ref->u.ar.type != AR_SECTION) |
1297 | return false; | |
538374c5 | 1298 | if (ref->next) |
1299 | return false; | |
eb89ca84 | 1300 | |
1301 | for (i = 0; i < ref->u.ar.dimen; i++) | |
1302 | { | |
9bf78879 | 1303 | /* If we have a single element in the reference, for the reference |
1304 | to be full, we need to ascertain that the array has a single | |
1305 | element in this dimension and that we actually reference the | |
1306 | correct element. */ | |
3d3e0f7d | 1307 | if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) |
1308 | { | |
9bf78879 | 1309 | /* This is unconditionally a contiguous reference if all the |
1310 | remaining dimensions are elements. */ | |
8d60cc46 | 1311 | if (contiguous) |
9bf78879 | 1312 | { |
1313 | *contiguous = true; | |
1314 | for (n = i + 1; n < ref->u.ar.dimen; n++) | |
1315 | if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) | |
1316 | *contiguous = false; | |
1317 | } | |
8d60cc46 | 1318 | |
3d3e0f7d | 1319 | if (!ref->u.ar.as |
1320 | || !ref->u.ar.as->lower[i] | |
1321 | || !ref->u.ar.as->upper[i] | |
1322 | || gfc_dep_compare_expr (ref->u.ar.as->lower[i], | |
1323 | ref->u.ar.as->upper[i]) | |
1324 | || !ref->u.ar.start[i] | |
1325 | || gfc_dep_compare_expr (ref->u.ar.start[i], | |
1326 | ref->u.ar.as->lower[i])) | |
1327 | return false; | |
1328 | else | |
1329 | continue; | |
1330 | } | |
1331 | ||
eb89ca84 | 1332 | /* Check the lower bound. */ |
1333 | if (ref->u.ar.start[i] | |
1334 | && (!ref->u.ar.as | |
1335 | || !ref->u.ar.as->lower[i] | |
1336 | || gfc_dep_compare_expr (ref->u.ar.start[i], | |
1337 | ref->u.ar.as->lower[i]))) | |
8d60cc46 | 1338 | lbound_OK = false; |
eb89ca84 | 1339 | /* Check the upper bound. */ |
1340 | if (ref->u.ar.end[i] | |
1341 | && (!ref->u.ar.as | |
1342 | || !ref->u.ar.as->upper[i] | |
1343 | || gfc_dep_compare_expr (ref->u.ar.end[i], | |
1344 | ref->u.ar.as->upper[i]))) | |
8d60cc46 | 1345 | ubound_OK = false; |
eb89ca84 | 1346 | /* Check the stride. */ |
9bf78879 | 1347 | if (ref->u.ar.stride[i] |
1348 | && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) | |
eb89ca84 | 1349 | return false; |
8d60cc46 | 1350 | |
9bf78879 | 1351 | /* This is unconditionally a contiguous reference as long as all |
1352 | the subsequent dimensions are elements. */ | |
8d60cc46 | 1353 | if (contiguous) |
9bf78879 | 1354 | { |
1355 | *contiguous = true; | |
1356 | for (n = i + 1; n < ref->u.ar.dimen; n++) | |
1357 | if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) | |
1358 | *contiguous = false; | |
1359 | } | |
8d60cc46 | 1360 | |
1361 | if (!lbound_OK || !ubound_OK) | |
1362 | return false; | |
eb89ca84 | 1363 | } |
1364 | return true; | |
1365 | } | |
1366 | ||
1367 | ||
4992c81a | 1368 | /* Determine if a full array is the same as an array section with one |
1369 | variable limit. For this to be so, the strides must both be unity | |
1370 | and one of either start == lower or end == upper must be true. */ | |
1371 | ||
1372 | static bool | |
1373 | ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) | |
1374 | { | |
1375 | int i; | |
1376 | bool upper_or_lower; | |
1377 | ||
1378 | if (full_ref->type != REF_ARRAY) | |
1379 | return false; | |
1380 | if (full_ref->u.ar.type != AR_FULL) | |
1381 | return false; | |
1382 | if (ref->type != REF_ARRAY) | |
1383 | return false; | |
1384 | if (ref->u.ar.type != AR_SECTION) | |
1385 | return false; | |
1386 | ||
1387 | for (i = 0; i < ref->u.ar.dimen; i++) | |
1388 | { | |
1389 | /* If we have a single element in the reference, we need to check | |
1390 | that the array has a single element and that we actually reference | |
1391 | the correct element. */ | |
1392 | if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) | |
1393 | { | |
1394 | if (!full_ref->u.ar.as | |
1395 | || !full_ref->u.ar.as->lower[i] | |
1396 | || !full_ref->u.ar.as->upper[i] | |
1397 | || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i], | |
1398 | full_ref->u.ar.as->upper[i]) | |
1399 | || !ref->u.ar.start[i] | |
1400 | || gfc_dep_compare_expr (ref->u.ar.start[i], | |
1401 | full_ref->u.ar.as->lower[i])) | |
1402 | return false; | |
1403 | } | |
1404 | ||
1405 | /* Check the strides. */ | |
1406 | if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0)) | |
1407 | return false; | |
1408 | if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) | |
1409 | return false; | |
1410 | ||
1411 | upper_or_lower = false; | |
1412 | /* Check the lower bound. */ | |
1413 | if (ref->u.ar.start[i] | |
1414 | && (ref->u.ar.as | |
1415 | && full_ref->u.ar.as->lower[i] | |
1416 | && gfc_dep_compare_expr (ref->u.ar.start[i], | |
1417 | full_ref->u.ar.as->lower[i]) == 0)) | |
1418 | upper_or_lower = true; | |
1419 | /* Check the upper bound. */ | |
1420 | if (ref->u.ar.end[i] | |
1421 | && (ref->u.ar.as | |
1422 | && full_ref->u.ar.as->upper[i] | |
1423 | && gfc_dep_compare_expr (ref->u.ar.end[i], | |
1424 | full_ref->u.ar.as->upper[i]) == 0)) | |
1425 | upper_or_lower = true; | |
1426 | if (!upper_or_lower) | |
1427 | return false; | |
1428 | } | |
1429 | return true; | |
1430 | } | |
1431 | ||
1432 | ||
4ee9c684 | 1433 | /* Finds if two array references are overlapping or not. |
1434 | Return value | |
1435 | 1 : array references are overlapping. | |
80425127 | 1436 | 0 : array references are identical or not overlapping. */ |
4ee9c684 | 1437 | |
1438 | int | |
1a9745d2 | 1439 | gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref) |
4ee9c684 | 1440 | { |
1441 | int n; | |
1442 | gfc_dependency fin_dep; | |
1443 | gfc_dependency this_dep; | |
1444 | ||
4ee9c684 | 1445 | fin_dep = GFC_DEP_ERROR; |
1446 | /* Dependencies due to pointers should already have been identified. | |
1447 | We only need to check for overlapping array references. */ | |
1448 | ||
1449 | while (lref && rref) | |
1450 | { | |
1451 | /* We're resolving from the same base symbol, so both refs should be | |
69b1505f | 1452 | the same type. We traverse the reference chain until we find ranges |
4ee9c684 | 1453 | that are not equal. */ |
22d678e8 | 1454 | gcc_assert (lref->type == rref->type); |
4ee9c684 | 1455 | switch (lref->type) |
1456 | { | |
1457 | case REF_COMPONENT: | |
1458 | /* The two ranges can't overlap if they are from different | |
1459 | components. */ | |
1460 | if (lref->u.c.component != rref->u.c.component) | |
1461 | return 0; | |
1462 | break; | |
1463 | ||
1464 | case REF_SUBSTRING: | |
791d4123 | 1465 | /* Substring overlaps are handled by the string assignment code |
1466 | if there is not an underlying dependency. */ | |
1467 | return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; | |
4ee9c684 | 1468 | |
1469 | case REF_ARRAY: | |
4992c81a | 1470 | |
1471 | if (ref_same_as_full_array (lref, rref)) | |
1472 | return 0; | |
1473 | ||
1474 | if (ref_same_as_full_array (rref, lref)) | |
1475 | return 0; | |
1476 | ||
1a9745d2 | 1477 | if (lref->u.ar.dimen != rref->u.ar.dimen) |
eb89ca84 | 1478 | { |
1479 | if (lref->u.ar.type == AR_FULL) | |
8d60cc46 | 1480 | fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL |
1481 | : GFC_DEP_OVERLAP; | |
eb89ca84 | 1482 | else if (rref->u.ar.type == AR_FULL) |
8d60cc46 | 1483 | fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL |
1484 | : GFC_DEP_OVERLAP; | |
eb89ca84 | 1485 | else |
1a9745d2 | 1486 | return 1; |
eb89ca84 | 1487 | break; |
1488 | } | |
1489 | ||
4ee9c684 | 1490 | for (n=0; n < lref->u.ar.dimen; n++) |
1491 | { | |
1492 | /* Assume dependency when either of array reference is vector | |
a7455f80 | 1493 | subscript. */ |
4ee9c684 | 1494 | if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR |
1495 | || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) | |
1496 | return 1; | |
1497 | if (lref->u.ar.dimen_type[n] == DIMEN_RANGE | |
1498 | && rref->u.ar.dimen_type[n] == DIMEN_RANGE) | |
1499 | this_dep = gfc_check_section_vs_section (lref, rref, n); | |
1500 | else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT | |
1501 | && rref->u.ar.dimen_type[n] == DIMEN_RANGE) | |
1502 | this_dep = gfc_check_element_vs_section (lref, rref, n); | |
1503 | else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT | |
1504 | && lref->u.ar.dimen_type[n] == DIMEN_RANGE) | |
1505 | this_dep = gfc_check_element_vs_section (rref, lref, n); | |
1506 | else | |
1507 | { | |
22d678e8 | 1508 | gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT |
a7455f80 | 1509 | && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); |
4ee9c684 | 1510 | this_dep = gfc_check_element_vs_element (rref, lref, n); |
1511 | } | |
1512 | ||
1513 | /* If any dimension doesn't overlap, we have no dependency. */ | |
1514 | if (this_dep == GFC_DEP_NODEP) | |
1515 | return 0; | |
1516 | ||
1517 | /* Overlap codes are in order of priority. We only need to | |
a7455f80 | 1518 | know the worst one.*/ |
4ee9c684 | 1519 | if (this_dep > fin_dep) |
1520 | fin_dep = this_dep; | |
1521 | } | |
caea6886 | 1522 | |
1523 | /* If this is an equal element, we have to keep going until we find | |
1524 | the "real" array reference. */ | |
1525 | if (lref->u.ar.type == AR_ELEMENT | |
1526 | && rref->u.ar.type == AR_ELEMENT | |
1527 | && fin_dep == GFC_DEP_EQUAL) | |
1528 | break; | |
1529 | ||
4ee9c684 | 1530 | /* Exactly matching and forward overlapping ranges don't cause a |
1531 | dependency. */ | |
1532 | if (fin_dep < GFC_DEP_OVERLAP) | |
1533 | return 0; | |
1534 | ||
1535 | /* Keep checking. We only have a dependency if | |
1536 | subsequent references also overlap. */ | |
1537 | break; | |
1538 | ||
1539 | default: | |
22d678e8 | 1540 | gcc_unreachable (); |
4ee9c684 | 1541 | } |
1542 | lref = lref->next; | |
1543 | rref = rref->next; | |
1544 | } | |
1545 | ||
1546 | /* If we haven't seen any array refs then something went wrong. */ | |
22d678e8 | 1547 | gcc_assert (fin_dep != GFC_DEP_ERROR); |
4ee9c684 | 1548 | |
80425127 | 1549 | /* Assume the worst if we nest to different depths. */ |
1550 | if (lref || rref) | |
4ee9c684 | 1551 | return 1; |
80425127 | 1552 | |
1553 | return fin_dep == GFC_DEP_OVERLAP; | |
4ee9c684 | 1554 | } |
1555 |