OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [dependency.c] - Blame information for rev 285

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 285 jeremybenn
/* Dependency analysis
2
   Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008, 2009, 2010
3
   Free Software Foundation, Inc.
4
   Contributed by Paul Brook <paul@nowt.org>
5
 
6
This file is part of GCC.
7
 
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
10
Software Foundation; either version 3, or (at your option) any later
11
version.
12
 
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.
17
 
18
You should have received a copy of the GNU General Public License
19
along with GCC; see the file COPYING3.  If not see
20
<http://www.gnu.org/licenses/>.  */
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
 
27
#include "config.h"
28
#include "gfortran.h"
29
#include "dependency.h"
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.  */
40
  GFC_DEP_FORWARD,      /* e.g., a(1:3), a(2:4).  */
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
54
gfc_expr_is_one (gfc_expr *expr, int def)
55
{
56
  gcc_assert (expr != NULL);
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
72
gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
73
{
74
  gfc_actual_arglist *args1;
75
  gfc_actual_arglist *args2;
76
  int i;
77
 
78
  if (e1->expr_type == EXPR_OP
79
      && (e1->value.op.op == INTRINSIC_UPLUS
80
          || e1->value.op.op == INTRINSIC_PARENTHESES))
81
    return gfc_dep_compare_expr (e1->value.op.op1, e2);
82
  if (e2->expr_type == EXPR_OP
83
      && (e2->value.op.op == INTRINSIC_UPLUS
84
          || e2->value.op.op == INTRINSIC_PARENTHESES))
85
    return gfc_dep_compare_expr (e1, e2->value.op.op1);
86
 
87
  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
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.  */
96
      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
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.  */
129
  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
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.  */
138
  if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
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.  */
146
      if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
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.  */
166
  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
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
 
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
 
197
    case EXPR_OP:
198
      /* Intrinsic operators are the same if their operands are the same.  */
199
      if (e1->value.op.op != e2->value.op.op)
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.  */
214
      if (e1->value.function.isym == 0 || e2->value.function.isym == 0
215
          || e1->value.function.isym != e2->value.function.isym)
216
        return -2;
217
 
218
      args1 = e1->value.function.actual;
219
      args2 = e2->value.function.actual;
220
 
221
      /* We should list the "constant" intrinsic functions.  Those
222
         without side-effects that provide equal results given equal
223
         argument lists.  */
224
      switch (e1->value.function.isym->id)
225
        {
226
        case GFC_ISYM_CONVERSION:
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
 
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.  */
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;
259
 
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
270
gfc_is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n, int def)
271
{
272
  gfc_expr *e1;
273
  gfc_expr *e2;
274
  int i;
275
 
276
  /* TODO: More sophisticated range comparison.  */
277
  gcc_assert (ar1 && ar2);
278
 
279
  gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
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];
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];
318
 
319
      if (ar2->as && !e2)
320
        e2 = ar2->as->lower[n];
321
 
322
      /* Check we have values for both.  */
323
      if (!(e1 && e2))
324
        return def;
325
 
326
      i = gfc_dep_compare_expr (e1, e2);
327
      if (i == -2)
328
        return def;
329
      else if (i != 0)
330
        return 0;
331
    }
332
 
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];
341
 
342
      if (ar2->as && !e2)
343
        e2 = ar2->as->upper[n];
344
 
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;
357
}
358
 
359
 
360
/* Some array-returning intrinsics can be implemented by reusing the
361
   data from one of the array arguments.  For example, TRANSPOSE does
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 *
370
gfc_get_noncopying_intrinsic_argument (gfc_expr *expr)
371
{
372
  if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
373
    return NULL;
374
 
375
  switch (expr->value.function.isym->id)
376
    {
377
    case GFC_ISYM_TRANSPOSE:
378
      return expr->value.function.actual->expr;
379
 
380
    default:
381
      return NULL;
382
    }
383
}
384
 
385
 
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
 
425
int
426
gfc_is_data_pointer (gfc_expr *e)
427
{
428
  gfc_ref *ref;
429
 
430
  if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
431
    return 0;
432
 
433
  /* No subreference if it is a function  */
434
  gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref);
435
 
436
  if (e->symtree->n.sym->attr.pointer)
437
    return 1;
438
 
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
 
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
456
gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
457
                                   gfc_expr *expr, gfc_dep_check elemental)
458
{
459
  gfc_expr *arg;
460
 
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:
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 == NOT_ELEMENTAL))
471
        {
472
          if (elemental == ELEM_DONT_CHECK_VARIABLE)
473
            {
474
              /* Too many false positive with pointers.  */
475
              if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
476
                {
477
                  /* Elemental procedures forbid unspecified intents,
478
                     and we don't check dependencies for INTENT_IN args.  */
479
                  gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
480
 
481
                  /* We are told not to check dependencies.
482
                     We do it, however, and issue a warning in case we find one.
483
                     If a dependency is found in the case
484
                     elemental == ELEM_CHECK_VARIABLE, we will generate
485
                     a temporary, so we don't need to bother the user.  */
486
                  gfc_warning ("INTENT(%s) actual argument at %L might "
487
                               "interfere with actual argument at %L.",
488
                               intent == INTENT_OUT ? "OUT" : "INOUT",
489
                               &var->where, &expr->where);
490
                }
491
              return 0;
492
            }
493
          else
494
            return 1;
495
        }
496
      return 0;
497
 
498
    case EXPR_ARRAY:
499
      return gfc_check_dependency (var, expr, 1);
500
 
501
    case EXPR_FUNCTION:
502
      if (intent != INTENT_IN && expr->inline_noncopying_intrinsic
503
          && (arg = gfc_get_noncopying_intrinsic_argument (expr))
504
          && gfc_check_argument_var_dependency (var, intent, arg, elemental))
505
        return 1;
506
      if (elemental)
507
        {
508
          if ((expr->value.function.esym
509
               && expr->value.function.esym->attr.elemental)
510
              || (expr->value.function.isym
511
                  && expr->value.function.isym->elemental))
512
            return gfc_check_fncall_dependency (var, intent, NULL,
513
                                                expr->value.function.actual,
514
                                                ELEM_CHECK_VARIABLE);
515
        }
516
      return 0;
517
 
518
    case EXPR_OP:
519
      /* In case of non-elemental procedures, there is no need to catch
520
         dependencies, as we will make a temporary anyway.  */
521
      if (elemental)
522
        {
523
          /* If the actual arg EXPR is an expression, we need to catch
524
             a dependency between variables in EXPR and VAR,
525
             an intent((IN)OUT) variable.  */
526
          if (expr->value.op.op1
527
              && gfc_check_argument_var_dependency (var, intent,
528
                                                    expr->value.op.op1,
529
                                                    ELEM_CHECK_VARIABLE))
530
            return 1;
531
          else if (expr->value.op.op2
532
                   && gfc_check_argument_var_dependency (var, intent,
533
                                                         expr->value.op.op2,
534
                                                         ELEM_CHECK_VARIABLE))
535
            return 1;
536
        }
537
      return 0;
538
 
539
    default:
540
      return 0;
541
    }
542
}
543
 
544
 
545
/* Like gfc_check_argument_var_dependency, but extended to any
546
   array expression OTHER, not just variables.  */
547
 
548
static int
549
gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
550
                               gfc_expr *expr, gfc_dep_check elemental)
551
{
552
  switch (other->expr_type)
553
    {
554
    case EXPR_VARIABLE:
555
      return gfc_check_argument_var_dependency (other, intent, expr, elemental);
556
 
557
    case EXPR_FUNCTION:
558
      if (other->inline_noncopying_intrinsic)
559
        {
560
          other = gfc_get_noncopying_intrinsic_argument (other);
561
          return gfc_check_argument_dependency (other, INTENT_IN, expr,
562
                                                elemental);
563
        }
564
      return 0;
565
 
566
    default:
567
      return 0;
568
    }
569
}
570
 
571
 
572
/* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
573
   FNSYM is the function being called, or NULL if not known.  */
574
 
575
int
576
gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
577
                             gfc_symbol *fnsym, gfc_actual_arglist *actual,
578
                             gfc_dep_check elemental)
579
{
580
  gfc_formal_arglist *formal;
581
  gfc_expr *expr;
582
 
583
  formal = fnsym ? fnsym->formal : NULL;
584
  for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
585
    {
586
      expr = actual->expr;
587
 
588
      /* Skip args which are not present.  */
589
      if (!expr)
590
        continue;
591
 
592
      /* Skip other itself.  */
593
      if (expr == other)
594
        continue;
595
 
596
      /* Skip intent(in) arguments if OTHER itself is intent(in).  */
597
      if (formal && intent == INTENT_IN
598
          && formal->sym->attr.intent == INTENT_IN)
599
        continue;
600
 
601
      if (gfc_check_argument_dependency (other, intent, expr, elemental))
602
        return 1;
603
    }
604
 
605
  return 0;
606
}
607
 
608
 
609
/* Return 1 if e1 and e2 are equivalenced arrays, either
610
   directly or indirectly; i.e., equivalence (a,b) for a and b
611
   or equivalence (a,c),(b,c).  This function uses the equiv_
612
   lists, generated in trans-common(add_equivalences), that are
613
   guaranteed to pick up indirect equivalences.  We explicitly
614
   check for overlap using the offset and length of the equivalence.
615
   This function is symmetric.
616
   TODO: This function only checks whether the full top-level
617
   symbols overlap.  An improved implementation could inspect
618
   e1->ref and e2->ref to determine whether the actually accessed
619
   portions of these variables/arrays potentially overlap.  */
620
 
621
int
622
gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
623
{
624
  gfc_equiv_list *l;
625
  gfc_equiv_info *s, *fl1, *fl2;
626
 
627
  gcc_assert (e1->expr_type == EXPR_VARIABLE
628
              && e2->expr_type == EXPR_VARIABLE);
629
 
630
  if (!e1->symtree->n.sym->attr.in_equivalence
631
      || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
632
    return 0;
633
 
634
  if (e1->symtree->n.sym->ns
635
        && e1->symtree->n.sym->ns != gfc_current_ns)
636
    l = e1->symtree->n.sym->ns->equiv_lists;
637
  else
638
    l = gfc_current_ns->equiv_lists;
639
 
640
  /* Go through the equiv_lists and return 1 if the variables
641
     e1 and e2 are members of the same group and satisfy the
642
     requirement on their relative offsets.  */
643
  for (; l; l = l->next)
644
    {
645
      fl1 = NULL;
646
      fl2 = NULL;
647
      for (s = l->equiv; s; s = s->next)
648
        {
649
          if (s->sym == e1->symtree->n.sym)
650
            {
651
              fl1 = s;
652
              if (fl2)
653
                break;
654
            }
655
          if (s->sym == e2->symtree->n.sym)
656
            {
657
              fl2 = s;
658
              if (fl1)
659
                break;
660
            }
661
        }
662
 
663
      if (s)
664
        {
665
          /* Can these lengths be zero?  */
666
          if (fl1->length <= 0 || fl2->length <= 0)
667
            return 1;
668
          /* These can't overlap if [f11,fl1+length] is before
669
             [fl2,fl2+length], or [fl2,fl2+length] is before
670
             [fl1,fl1+length], otherwise they do overlap.  */
671
          if (fl1->offset + fl1->length > fl2->offset
672
              && fl2->offset + fl2->length > fl1->offset)
673
            return 1;
674
        }
675
    }
676
  return 0;
677
}
678
 
679
 
680
/* Return true if there is no possibility of aliasing because of a type
681
   mismatch between all the possible pointer references and the
682
   potential target.  Note that this function is asymmetric in the
683
   arguments and so must be called twice with the arguments exchanged.  */
684
 
685
static bool
686
check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2)
687
{
688
  gfc_component *cm1;
689
  gfc_symbol *sym1;
690
  gfc_symbol *sym2;
691
  gfc_ref *ref1;
692
  bool seen_component_ref;
693
 
694
  if (expr1->expr_type != EXPR_VARIABLE
695
        || expr1->expr_type != EXPR_VARIABLE)
696
    return false;
697
 
698
  sym1 = expr1->symtree->n.sym;
699
  sym2 = expr2->symtree->n.sym;
700
 
701
  /* Keep it simple for now.  */
702
  if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED)
703
    return false;
704
 
705
  if (sym1->attr.pointer)
706
    {
707
      if (gfc_compare_types (&sym1->ts, &sym2->ts))
708
        return false;
709
    }
710
 
711
  /* This is a conservative check on the components of the derived type
712
     if no component references have been seen.  Since we will not dig
713
     into the components of derived type components, we play it safe by
714
     returning false.  First we check the reference chain and then, if
715
     no component references have been seen, the components.  */
716
  seen_component_ref = false;
717
  if (sym1->ts.type == BT_DERIVED)
718
    {
719
      for (ref1 = expr1->ref; ref1; ref1 = ref1->next)
720
        {
721
          if (ref1->type != REF_COMPONENT)
722
            continue;
723
 
724
          if (ref1->u.c.component->ts.type == BT_DERIVED)
725
            return false;
726
 
727
          if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer)
728
                && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts))
729
            return false;
730
 
731
          seen_component_ref = true;
732
        }
733
    }
734
 
735
  if (sym1->ts.type == BT_DERIVED && !seen_component_ref)
736
    {
737
      for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next)
738
        {
739
          if (cm1->ts.type == BT_DERIVED)
740
            return false;
741
 
742
          if ((sym2->attr.pointer || cm1->attr.pointer)
743
                && gfc_compare_types (&cm1->ts, &sym2->ts))
744
            return false;
745
        }
746
    }
747
 
748
  return true;
749
}
750
 
751
 
752
/* Return true if the statement body redefines the condition.  Returns
753
   true if expr2 depends on expr1.  expr1 should be a single term
754
   suitable for the lhs of an assignment.  The IDENTICAL flag indicates
755
   whether array references to the same symbol with identical range
756
   references count as a dependency or not.  Used for forall and where
757
   statements.  Also used with functions returning arrays without a
758
   temporary.  */
759
 
760
int
761
gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
762
{
763
  gfc_actual_arglist *actual;
764
  gfc_constructor *c;
765
  int n;
766
 
767
  gcc_assert (expr1->expr_type == EXPR_VARIABLE);
768
 
769
  switch (expr2->expr_type)
770
    {
771
    case EXPR_OP:
772
      n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
773
      if (n)
774
        return n;
775
      if (expr2->value.op.op2)
776
        return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
777
      return 0;
778
 
779
    case EXPR_VARIABLE:
780
      /* The interesting cases are when the symbols don't match.  */
781
      if (expr1->symtree->n.sym != expr2->symtree->n.sym)
782
        {
783
          gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
784
          gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
785
 
786
          /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
787
          if (gfc_are_equivalenced_arrays (expr1, expr2))
788
            return 1;
789
 
790
          /* Symbols can only alias if they have the same type.  */
791
          if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
792
              && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
793
            {
794
              if (ts1->type != ts2->type || ts1->kind != ts2->kind)
795
                return 0;
796
            }
797
 
798
          /* If either variable is a pointer, assume the worst.  */
799
          /* TODO: -fassume-no-pointer-aliasing */
800
          if (gfc_is_data_pointer (expr1) || gfc_is_data_pointer (expr2))
801
            {
802
              if (check_data_pointer_types (expr1, expr2)
803
                    && check_data_pointer_types (expr2, expr1))
804
                return 0;
805
 
806
              return 1;
807
            }
808
 
809
          /* Otherwise distinct symbols have no dependencies.  */
810
          return 0;
811
        }
812
 
813
      if (identical)
814
        return 1;
815
 
816
      /* Identical and disjoint ranges return 0,
817
         overlapping ranges return 1.  */
818
      if (expr1->ref && expr2->ref)
819
        return gfc_dep_resolver (expr1->ref, expr2->ref);
820
 
821
      return 1;
822
 
823
    case EXPR_FUNCTION:
824
      if (expr2->inline_noncopying_intrinsic)
825
        identical = 1;
826
      /* Remember possible differences between elemental and
827
         transformational functions.  All functions inside a FORALL
828
         will be pure.  */
829
      for (actual = expr2->value.function.actual;
830
           actual; actual = actual->next)
831
        {
832
          if (!actual->expr)
833
            continue;
834
          n = gfc_check_dependency (expr1, actual->expr, identical);
835
          if (n)
836
            return n;
837
        }
838
      return 0;
839
 
840
    case EXPR_CONSTANT:
841
    case EXPR_NULL:
842
      return 0;
843
 
844
    case EXPR_ARRAY:
845
      /* Loop through the array constructor's elements.  */
846
      for (c = expr2->value.constructor; c; c = c->next)
847
        {
848
          /* If this is an iterator, assume the worst.  */
849
          if (c->iterator)
850
            return 1;
851
          /* Avoid recursion in the common case.  */
852
          if (c->expr->expr_type == EXPR_CONSTANT)
853
            continue;
854
          if (gfc_check_dependency (expr1, c->expr, 1))
855
            return 1;
856
        }
857
      return 0;
858
 
859
    default:
860
      return 1;
861
    }
862
}
863
 
864
 
865
/* Determines overlapping for two array sections.  */
866
 
867
static gfc_dependency
868
gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
869
{
870
  gfc_array_ref l_ar;
871
  gfc_expr *l_start;
872
  gfc_expr *l_end;
873
  gfc_expr *l_stride;
874
  gfc_expr *l_lower;
875
  gfc_expr *l_upper;
876
  int l_dir;
877
 
878
  gfc_array_ref r_ar;
879
  gfc_expr *r_start;
880
  gfc_expr *r_end;
881
  gfc_expr *r_stride;
882
  gfc_expr *r_lower;
883
  gfc_expr *r_upper;
884
  int r_dir;
885
 
886
  l_ar = lref->u.ar;
887
  r_ar = rref->u.ar;
888
 
889
  /* If they are the same range, return without more ado.  */
890
  if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
891
    return GFC_DEP_EQUAL;
892
 
893
  l_start = l_ar.start[n];
894
  l_end = l_ar.end[n];
895
  l_stride = l_ar.stride[n];
896
 
897
  r_start = r_ar.start[n];
898
  r_end = r_ar.end[n];
899
  r_stride = r_ar.stride[n];
900
 
901
  /* If l_start is NULL take it from array specifier.  */
902
  if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as))
903
    l_start = l_ar.as->lower[n];
904
  /* If l_end is NULL take it from array specifier.  */
905
  if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as))
906
    l_end = l_ar.as->upper[n];
907
 
908
  /* If r_start is NULL take it from array specifier.  */
909
  if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
910
    r_start = r_ar.as->lower[n];
911
  /* If r_end is NULL take it from array specifier.  */
912
  if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
913
    r_end = r_ar.as->upper[n];
914
 
915
  /* Determine whether the l_stride is positive or negative.  */
916
  if (!l_stride)
917
    l_dir = 1;
918
  else if (l_stride->expr_type == EXPR_CONSTANT
919
           && l_stride->ts.type == BT_INTEGER)
920
    l_dir = mpz_sgn (l_stride->value.integer);
921
  else if (l_start && l_end)
922
    l_dir = gfc_dep_compare_expr (l_end, l_start);
923
  else
924
    l_dir = -2;
925
 
926
  /* Determine whether the r_stride is positive or negative.  */
927
  if (!r_stride)
928
    r_dir = 1;
929
  else if (r_stride->expr_type == EXPR_CONSTANT
930
           && r_stride->ts.type == BT_INTEGER)
931
    r_dir = mpz_sgn (r_stride->value.integer);
932
  else if (r_start && r_end)
933
    r_dir = gfc_dep_compare_expr (r_end, r_start);
934
  else
935
    r_dir = -2;
936
 
937
  /* The strides should never be zero.  */
938
  if (l_dir == 0 || r_dir == 0)
939
    return GFC_DEP_OVERLAP;
940
 
941
  /* Determine LHS upper and lower bounds.  */
942
  if (l_dir == 1)
943
    {
944
      l_lower = l_start;
945
      l_upper = l_end;
946
    }
947
  else if (l_dir == -1)
948
    {
949
      l_lower = l_end;
950
      l_upper = l_start;
951
    }
952
  else
953
    {
954
      l_lower = NULL;
955
      l_upper = NULL;
956
    }
957
 
958
  /* Determine RHS upper and lower bounds.  */
959
  if (r_dir == 1)
960
    {
961
      r_lower = r_start;
962
      r_upper = r_end;
963
    }
964
  else if (r_dir == -1)
965
    {
966
      r_lower = r_end;
967
      r_upper = r_start;
968
    }
969
  else
970
    {
971
      r_lower = NULL;
972
      r_upper = NULL;
973
    }
974
 
975
  /* Check whether the ranges are disjoint.  */
976
  if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
977
    return GFC_DEP_NODEP;
978
  if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
979
    return GFC_DEP_NODEP;
980
 
981
  /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
982
  if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
983
    {
984
      if (l_dir == 1 && r_dir == -1)
985
        return GFC_DEP_EQUAL;
986
      if (l_dir == -1 && r_dir == 1)
987
        return GFC_DEP_EQUAL;
988
    }
989
 
990
  /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
991
  if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
992
    {
993
      if (l_dir == 1 && r_dir == -1)
994
        return GFC_DEP_EQUAL;
995
      if (l_dir == -1 && r_dir == 1)
996
        return GFC_DEP_EQUAL;
997
    }
998
 
999
  /* Check for forward dependencies x:y vs. x+1:z.  */
1000
  if (l_dir == 1 && r_dir == 1
1001
      && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
1002
      && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
1003
    {
1004
      /* Check that the strides are the same.  */
1005
      if (!l_stride && !r_stride)
1006
        return GFC_DEP_FORWARD;
1007
      if (l_stride && r_stride
1008
          && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1009
        return GFC_DEP_FORWARD;
1010
    }
1011
 
1012
  /* Check for forward dependencies x:y:-1 vs. x-1:z:-1.  */
1013
  if (l_dir == -1 && r_dir == -1
1014
      && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
1015
      && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
1016
    {
1017
      /* Check that the strides are the same.  */
1018
      if (!l_stride && !r_stride)
1019
        return GFC_DEP_FORWARD;
1020
      if (l_stride && r_stride
1021
          && gfc_dep_compare_expr (l_stride, r_stride) == 0)
1022
        return GFC_DEP_FORWARD;
1023
    }
1024
 
1025
  return GFC_DEP_OVERLAP;
1026
}
1027
 
1028
 
1029
/* Determines overlapping for a single element and a section.  */
1030
 
1031
static gfc_dependency
1032
gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
1033
{
1034
  gfc_array_ref *ref;
1035
  gfc_expr *elem;
1036
  gfc_expr *start;
1037
  gfc_expr *end;
1038
  gfc_expr *stride;
1039
  int s;
1040
 
1041
  elem = lref->u.ar.start[n];
1042
  if (!elem)
1043
    return GFC_DEP_OVERLAP;
1044
 
1045
  ref = &rref->u.ar;
1046
  start = ref->start[n] ;
1047
  end = ref->end[n] ;
1048
  stride = ref->stride[n];
1049
 
1050
  if (!start && IS_ARRAY_EXPLICIT (ref->as))
1051
    start = ref->as->lower[n];
1052
  if (!end && IS_ARRAY_EXPLICIT (ref->as))
1053
    end = ref->as->upper[n];
1054
 
1055
  /* Determine whether the stride is positive or negative.  */
1056
  if (!stride)
1057
    s = 1;
1058
  else if (stride->expr_type == EXPR_CONSTANT
1059
           && stride->ts.type == BT_INTEGER)
1060
    s = mpz_sgn (stride->value.integer);
1061
  else
1062
    s = -2;
1063
 
1064
  /* Stride should never be zero.  */
1065
  if (s == 0)
1066
    return GFC_DEP_OVERLAP;
1067
 
1068
  /* Positive strides.  */
1069
  if (s == 1)
1070
    {
1071
      /* Check for elem < lower.  */
1072
      if (start && gfc_dep_compare_expr (elem, start) == -1)
1073
        return GFC_DEP_NODEP;
1074
      /* Check for elem > upper.  */
1075
      if (end && gfc_dep_compare_expr (elem, end) == 1)
1076
        return GFC_DEP_NODEP;
1077
 
1078
      if (start && end)
1079
        {
1080
          s = gfc_dep_compare_expr (start, end);
1081
          /* Check for an empty range.  */
1082
          if (s == 1)
1083
            return GFC_DEP_NODEP;
1084
          if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1085
            return GFC_DEP_EQUAL;
1086
        }
1087
    }
1088
  /* Negative strides.  */
1089
  else if (s == -1)
1090
    {
1091
      /* Check for elem > upper.  */
1092
      if (end && gfc_dep_compare_expr (elem, start) == 1)
1093
        return GFC_DEP_NODEP;
1094
      /* Check for elem < lower.  */
1095
      if (start && gfc_dep_compare_expr (elem, end) == -1)
1096
        return GFC_DEP_NODEP;
1097
 
1098
      if (start && end)
1099
        {
1100
          s = gfc_dep_compare_expr (start, end);
1101
          /* Check for an empty range.  */
1102
          if (s == -1)
1103
            return GFC_DEP_NODEP;
1104
          if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
1105
            return GFC_DEP_EQUAL;
1106
        }
1107
    }
1108
  /* Unknown strides.  */
1109
  else
1110
    {
1111
      if (!start || !end)
1112
        return GFC_DEP_OVERLAP;
1113
      s = gfc_dep_compare_expr (start, end);
1114
      if (s == -2)
1115
        return GFC_DEP_OVERLAP;
1116
      /* Assume positive stride.  */
1117
      if (s == -1)
1118
        {
1119
          /* Check for elem < lower.  */
1120
          if (gfc_dep_compare_expr (elem, start) == -1)
1121
            return GFC_DEP_NODEP;
1122
          /* Check for elem > upper.  */
1123
          if (gfc_dep_compare_expr (elem, end) == 1)
1124
            return GFC_DEP_NODEP;
1125
        }
1126
      /* Assume negative stride.  */
1127
      else if (s == 1)
1128
        {
1129
          /* Check for elem > upper.  */
1130
          if (gfc_dep_compare_expr (elem, start) == 1)
1131
            return GFC_DEP_NODEP;
1132
          /* Check for elem < lower.  */
1133
          if (gfc_dep_compare_expr (elem, end) == -1)
1134
            return GFC_DEP_NODEP;
1135
        }
1136
      /* Equal bounds.  */
1137
      else if (s == 0)
1138
        {
1139
          s = gfc_dep_compare_expr (elem, start);
1140
          if (s == 0)
1141
            return GFC_DEP_EQUAL;
1142
          if (s == 1 || s == -1)
1143
            return GFC_DEP_NODEP;
1144
        }
1145
    }
1146
 
1147
  return GFC_DEP_OVERLAP;
1148
}
1149
 
1150
 
1151
/* Traverse expr, checking all EXPR_VARIABLE symbols for their
1152
   forall_index attribute.  Return true if any variable may be
1153
   being used as a FORALL index.  Its safe to pessimistically
1154
   return true, and assume a dependency.  */
1155
 
1156
static bool
1157
contains_forall_index_p (gfc_expr *expr)
1158
{
1159
  gfc_actual_arglist *arg;
1160
  gfc_constructor *c;
1161
  gfc_ref *ref;
1162
  int i;
1163
 
1164
  if (!expr)
1165
    return false;
1166
 
1167
  switch (expr->expr_type)
1168
    {
1169
    case EXPR_VARIABLE:
1170
      if (expr->symtree->n.sym->forall_index)
1171
        return true;
1172
      break;
1173
 
1174
    case EXPR_OP:
1175
      if (contains_forall_index_p (expr->value.op.op1)
1176
          || contains_forall_index_p (expr->value.op.op2))
1177
        return true;
1178
      break;
1179
 
1180
    case EXPR_FUNCTION:
1181
      for (arg = expr->value.function.actual; arg; arg = arg->next)
1182
        if (contains_forall_index_p (arg->expr))
1183
          return true;
1184
      break;
1185
 
1186
    case EXPR_CONSTANT:
1187
    case EXPR_NULL:
1188
    case EXPR_SUBSTRING:
1189
      break;
1190
 
1191
    case EXPR_STRUCTURE:
1192
    case EXPR_ARRAY:
1193
      for (c = expr->value.constructor; c; c = c->next)
1194
        if (contains_forall_index_p (c->expr))
1195
          return true;
1196
      break;
1197
 
1198
    default:
1199
      gcc_unreachable ();
1200
    }
1201
 
1202
  for (ref = expr->ref; ref; ref = ref->next)
1203
    switch (ref->type)
1204
      {
1205
      case REF_ARRAY:
1206
        for (i = 0; i < ref->u.ar.dimen; i++)
1207
          if (contains_forall_index_p (ref->u.ar.start[i])
1208
              || contains_forall_index_p (ref->u.ar.end[i])
1209
              || contains_forall_index_p (ref->u.ar.stride[i]))
1210
            return true;
1211
        break;
1212
 
1213
      case REF_COMPONENT:
1214
        break;
1215
 
1216
      case REF_SUBSTRING:
1217
        if (contains_forall_index_p (ref->u.ss.start)
1218
            || contains_forall_index_p (ref->u.ss.end))
1219
          return true;
1220
        break;
1221
 
1222
      default:
1223
        gcc_unreachable ();
1224
      }
1225
 
1226
  return false;
1227
}
1228
 
1229
/* Determines overlapping for two single element array references.  */
1230
 
1231
static gfc_dependency
1232
gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1233
{
1234
  gfc_array_ref l_ar;
1235
  gfc_array_ref r_ar;
1236
  gfc_expr *l_start;
1237
  gfc_expr *r_start;
1238
  int i;
1239
 
1240
  l_ar = lref->u.ar;
1241
  r_ar = rref->u.ar;
1242
  l_start = l_ar.start[n] ;
1243
  r_start = r_ar.start[n] ;
1244
  i = gfc_dep_compare_expr (r_start, l_start);
1245
  if (i == 0)
1246
    return GFC_DEP_EQUAL;
1247
 
1248
  /* Treat two scalar variables as potentially equal.  This allows
1249
     us to prove that a(i,:) and a(j,:) have no dependency.  See
1250
     Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1251
     Proceedings of the International Conference on Parallel and
1252
     Distributed Processing Techniques and Applications (PDPTA2001),
1253
     Las Vegas, Nevada, June 2001.  */
1254
  /* However, we need to be careful when either scalar expression
1255
     contains a FORALL index, as these can potentially change value
1256
     during the scalarization/traversal of this array reference.  */
1257
  if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1258
    return GFC_DEP_OVERLAP;
1259
 
1260
  if (i != -2)
1261
    return GFC_DEP_NODEP;
1262
  return GFC_DEP_EQUAL;
1263
}
1264
 
1265
 
1266
/* Determine if an array ref, usually an array section specifies the
1267
   entire array.  In addition, if the second, pointer argument is
1268
   provided, the function will return true if the reference is
1269
   contiguous; eg. (:, 1) gives true but (1,:) gives false.  */
1270
 
1271
bool
1272
gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous)
1273
{
1274
  int i;
1275
  int n;
1276
  bool lbound_OK = true;
1277
  bool ubound_OK = true;
1278
 
1279
  if (contiguous)
1280
    *contiguous = false;
1281
 
1282
  if (ref->type != REF_ARRAY)
1283
    return false;
1284
 
1285
  if (ref->u.ar.type == AR_FULL)
1286
    {
1287
      if (contiguous)
1288
        *contiguous = true;
1289
      return true;
1290
    }
1291
 
1292
  if (ref->u.ar.type != AR_SECTION)
1293
    return false;
1294
  if (ref->next)
1295
    return false;
1296
 
1297
  for (i = 0; i < ref->u.ar.dimen; i++)
1298
    {
1299
      /* If we have a single element in the reference, for the reference
1300
         to be full, we need to ascertain that the array has a single
1301
         element in this dimension and that we actually reference the
1302
         correct element.  */
1303
      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1304
        {
1305
          /* This is unconditionally a contiguous reference if all the
1306
             remaining dimensions are elements.  */
1307
          if (contiguous)
1308
            {
1309
              *contiguous = true;
1310
              for (n = i + 1; n < ref->u.ar.dimen; n++)
1311
                if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1312
                  *contiguous = false;
1313
            }
1314
 
1315
          if (!ref->u.ar.as
1316
              || !ref->u.ar.as->lower[i]
1317
              || !ref->u.ar.as->upper[i]
1318
              || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1319
                                       ref->u.ar.as->upper[i])
1320
              || !ref->u.ar.start[i]
1321
              || gfc_dep_compare_expr (ref->u.ar.start[i],
1322
                                       ref->u.ar.as->lower[i]))
1323
            return false;
1324
          else
1325
            continue;
1326
        }
1327
 
1328
      /* Check the lower bound.  */
1329
      if (ref->u.ar.start[i]
1330
          && (!ref->u.ar.as
1331
              || !ref->u.ar.as->lower[i]
1332
              || gfc_dep_compare_expr (ref->u.ar.start[i],
1333
                                       ref->u.ar.as->lower[i])))
1334
        lbound_OK = false;
1335
      /* Check the upper bound.  */
1336
      if (ref->u.ar.end[i]
1337
          && (!ref->u.ar.as
1338
              || !ref->u.ar.as->upper[i]
1339
              || gfc_dep_compare_expr (ref->u.ar.end[i],
1340
                                       ref->u.ar.as->upper[i])))
1341
        ubound_OK = false;
1342
      /* Check the stride.  */
1343
      if (ref->u.ar.stride[i]
1344
            && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1345
        return false;
1346
 
1347
      /* This is unconditionally a contiguous reference as long as all
1348
         the subsequent dimensions are elements.  */
1349
      if (contiguous)
1350
        {
1351
          *contiguous = true;
1352
          for (n = i + 1; n < ref->u.ar.dimen; n++)
1353
            if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1354
              *contiguous = false;
1355
        }
1356
 
1357
      if (!lbound_OK || !ubound_OK)
1358
        return false;
1359
    }
1360
  return true;
1361
}
1362
 
1363
 
1364
/* Determine if a full array is the same as an array section with one
1365
   variable limit.  For this to be so, the strides must both be unity
1366
   and one of either start == lower or end == upper must be true.  */
1367
 
1368
static bool
1369
ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref)
1370
{
1371
  int i;
1372
  bool upper_or_lower;
1373
 
1374
  if (full_ref->type != REF_ARRAY)
1375
    return false;
1376
  if (full_ref->u.ar.type != AR_FULL)
1377
    return false;
1378
  if (ref->type != REF_ARRAY)
1379
    return false;
1380
  if (ref->u.ar.type != AR_SECTION)
1381
    return false;
1382
 
1383
  for (i = 0; i < ref->u.ar.dimen; i++)
1384
    {
1385
      /* If we have a single element in the reference, we need to check
1386
         that the array has a single element and that we actually reference
1387
         the correct element.  */
1388
      if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1389
        {
1390
          if (!full_ref->u.ar.as
1391
              || !full_ref->u.ar.as->lower[i]
1392
              || !full_ref->u.ar.as->upper[i]
1393
              || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i],
1394
                                       full_ref->u.ar.as->upper[i])
1395
              || !ref->u.ar.start[i]
1396
              || gfc_dep_compare_expr (ref->u.ar.start[i],
1397
                                       full_ref->u.ar.as->lower[i]))
1398
            return false;
1399
        }
1400
 
1401
      /* Check the strides.  */
1402
      if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0))
1403
        return false;
1404
      if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1405
        return false;
1406
 
1407
      upper_or_lower = false;
1408
      /* Check the lower bound.  */
1409
      if (ref->u.ar.start[i]
1410
          && (ref->u.ar.as
1411
                && full_ref->u.ar.as->lower[i]
1412
                && gfc_dep_compare_expr (ref->u.ar.start[i],
1413
                                         full_ref->u.ar.as->lower[i]) == 0))
1414
        upper_or_lower =  true;
1415
      /* Check the upper bound.  */
1416
      if (ref->u.ar.end[i]
1417
          && (ref->u.ar.as
1418
                && full_ref->u.ar.as->upper[i]
1419
                && gfc_dep_compare_expr (ref->u.ar.end[i],
1420
                                         full_ref->u.ar.as->upper[i]) == 0))
1421
        upper_or_lower =  true;
1422
      if (!upper_or_lower)
1423
        return false;
1424
    }
1425
  return true;
1426
}
1427
 
1428
 
1429
/* Finds if two array references are overlapping or not.
1430
   Return value
1431
        1 : array references are overlapping.
1432
 
1433
 
1434
int
1435
gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
1436
{
1437
  int n;
1438
  gfc_dependency fin_dep;
1439
  gfc_dependency this_dep;
1440
 
1441
  fin_dep = GFC_DEP_ERROR;
1442
  /* Dependencies due to pointers should already have been identified.
1443
     We only need to check for overlapping array references.  */
1444
 
1445
  while (lref && rref)
1446
    {
1447
      /* We're resolving from the same base symbol, so both refs should be
1448
         the same type.  We traverse the reference chain until we find ranges
1449
         that are not equal.  */
1450
      gcc_assert (lref->type == rref->type);
1451
      switch (lref->type)
1452
        {
1453
        case REF_COMPONENT:
1454
          /* The two ranges can't overlap if they are from different
1455
             components.  */
1456
          if (lref->u.c.component != rref->u.c.component)
1457
            return 0;
1458
          break;
1459
 
1460
        case REF_SUBSTRING:
1461
          /* Substring overlaps are handled by the string assignment code
1462
             if there is not an underlying dependency.  */
1463
          return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1464
 
1465
        case REF_ARRAY:
1466
 
1467
          if (ref_same_as_full_array (lref, rref))
1468
            return 0;
1469
 
1470
          if (ref_same_as_full_array (rref, lref))
1471
            return 0;
1472
 
1473
          if (lref->u.ar.dimen != rref->u.ar.dimen)
1474
            {
1475
              if (lref->u.ar.type == AR_FULL)
1476
                fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL
1477
                                                            : GFC_DEP_OVERLAP;
1478
              else if (rref->u.ar.type == AR_FULL)
1479
                fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL
1480
                                                            : GFC_DEP_OVERLAP;
1481
              else
1482
                return 1;
1483
              break;
1484
            }
1485
 
1486
          for (n=0; n < lref->u.ar.dimen; n++)
1487
            {
1488
              /* Assume dependency when either of array reference is vector
1489
                 subscript.  */
1490
              if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1491
                  || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1492
                return 1;
1493
              if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1494
                  && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1495
                this_dep = gfc_check_section_vs_section (lref, rref, n);
1496
              else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1497
                       && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1498
                this_dep = gfc_check_element_vs_section (lref, rref, n);
1499
              else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1500
                       && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1501
                this_dep = gfc_check_element_vs_section (rref, lref, n);
1502
              else
1503
                {
1504
                  gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1505
                              && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1506
                  this_dep = gfc_check_element_vs_element (rref, lref, n);
1507
                }
1508
 
1509
              /* If any dimension doesn't overlap, we have no dependency.  */
1510
              if (this_dep == GFC_DEP_NODEP)
1511
                return 0;
1512
 
1513
              /* Overlap codes are in order of priority.  We only need to
1514
                 know the worst one.*/
1515
              if (this_dep > fin_dep)
1516
                fin_dep = this_dep;
1517
            }
1518
 
1519
          /* If this is an equal element, we have to keep going until we find
1520
             the "real" array reference.  */
1521
          if (lref->u.ar.type == AR_ELEMENT
1522
                && rref->u.ar.type == AR_ELEMENT
1523
                && fin_dep == GFC_DEP_EQUAL)
1524
            break;
1525
 
1526
          /* Exactly matching and forward overlapping ranges don't cause a
1527
             dependency.  */
1528
          if (fin_dep < GFC_DEP_OVERLAP)
1529
            return 0;
1530
 
1531
          /* Keep checking.  We only have a dependency if
1532
             subsequent references also overlap.  */
1533
          break;
1534
 
1535
        default:
1536
          gcc_unreachable ();
1537
        }
1538
      lref = lref->next;
1539
      rref = rref->next;
1540
    }
1541
 
1542
  /* If we haven't seen any array refs then something went wrong.  */
1543
  gcc_assert (fin_dep != GFC_DEP_ERROR);
1544
 
1545
  /* Assume the worst if we nest to different depths.  */
1546
  if (lref || rref)
1547
    return 1;
1548
 
1549
  return fin_dep == GFC_DEP_OVERLAP;
1550
}
1551
 

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.