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