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