gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005, 2006, 2007, 2008
   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,      /* eg. 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.operator == INTRINSIC_UPLUS
  80           || e1->value.op.operator == INTRINSIC_PARENTHESES))
  81     return gfc_dep_compare_expr (e1->value.op.op1, e2);
  82   if (e2->expr_type == EXPR_OP
  83       && (e2->value.op.operator == INTRINSIC_UPLUS
  84           || e2->value.op.operator == INTRINSIC_PARENTHESES))
  85     return gfc_dep_compare_expr (e1, e2->value.op.op1);
  86
  87   if (e1->expr_type == EXPR_OP && e1->value.op.operator == 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.operator == 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.operator == 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.operator == 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.operator == 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.operator == 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.operator != e2->value.op.operator)
 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 /* Return true if array variable VAR could be passed to the same function
 426    as argument EXPR without interfering with EXPR.  INTENT is the intent
 427    of VAR.
 428
 429    This is considerably less conservative than other dependencies
 430    because many function arguments will already be copied into a
 431    temporary.  */
 432
 433 static int
 434 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
 435                                    gfc_expr *expr)
 436 {
 437   gcc_assert (var->expr_type == EXPR_VARIABLE);
 438   gcc_assert (var->rank > 0);
 439
 440   switch (expr->expr_type)
 441     {
 442     case EXPR_VARIABLE:
 443       return (gfc_ref_needs_temporary_p (expr->ref)
 444               || gfc_check_dependency (var, expr, 1));
 445
 446     case EXPR_ARRAY:
 447       return gfc_check_dependency (var, expr, 1);
 448
 449     case EXPR_FUNCTION:
 450       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
 451         {
 452           expr = gfc_get_noncopying_intrinsic_argument (expr);
 453           return gfc_check_argument_var_dependency (var, intent, expr);
 454         }
 455       return 0;
 456
 457     default:
 458       return 0;
 459     }
 460 }
 461
 462
 463 /* Like gfc_check_argument_var_dependency, but extended to any
 464    array expression OTHER, not just variables.  */
 465
 466 static int
 467 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent,
 468                                gfc_expr *expr)
 469 {
 470   switch (other->expr_type)
 471     {
 472     case EXPR_VARIABLE:
 473       return gfc_check_argument_var_dependency (other, intent, expr);
 474
 475     case EXPR_FUNCTION:
 476       if (other->inline_noncopying_intrinsic)
 477         {
 478           other = gfc_get_noncopying_intrinsic_argument (other);
 479           return gfc_check_argument_dependency (other, INTENT_IN, expr);
 480         }
 481       return 0;
 482
 483     default:
 484       return 0;
 485     }
 486 }
 487
 488
 489 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 490    FNSYM is the function being called, or NULL if not known.  */
 491
 492 int
 493 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent,
 494                              gfc_symbol *fnsym, gfc_actual_arglist *actual)
 495 {
 496   gfc_formal_arglist *formal;
 497   gfc_expr *expr;
 498
 499   formal = fnsym ? fnsym->formal : NULL;
 500   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 501     {
 502       expr = actual->expr;
 503
 504       /* Skip args which are not present.  */
 505       if (!expr)
 506         continue;
 507
 508       /* Skip other itself.  */
 509       if (expr == other)
 510         continue;
 511
 512       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 513       if (formal && intent == INTENT_IN
 514           && formal->sym->attr.intent == INTENT_IN)
 515         continue;
 516
 517       if (gfc_check_argument_dependency (other, intent, expr))
 518         return 1;
 519     }
 520
 521   return 0;
 522 }
 523
 524
 525 /* Return 1 if e1 and e2 are equivalenced arrays, either
 526    directly or indirectly; ie. equivalence (a,b) for a and b
 527    or equivalence (a,c),(b,c).  This function uses the equiv_
 528    lists, generated in trans-common(add_equivalences), that are
 529    guaranteed to pick up indirect equivalences.  We explicitly
 530    check for overlap using the offset and length of the equivalence.
 531    This function is symmetric.
 532    TODO: This function only checks whether the full top-level
 533    symbols overlap.  An improved implementation could inspect
 534    e1->ref and e2->ref to determine whether the actually accessed
 535    portions of these variables/arrays potentially overlap.  */
 536
 537 int
 538 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 539 {
 540   gfc_equiv_list *l;
 541   gfc_equiv_info *s, *fl1, *fl2;
 542
 543   gcc_assert (e1->expr_type == EXPR_VARIABLE
 544               && e2->expr_type == EXPR_VARIABLE);
 545
 546   if (!e1->symtree->n.sym->attr.in_equivalence
 547       || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank)
 548     return 0;
 549
 550   /* Go through the equiv_lists and return 1 if the variables
 551      e1 and e2 are members of the same group and satisfy the
 552      requirement on their relative offsets.  */
 553   for (l = gfc_current_ns->equiv_lists; l; l = l->next)
 554     {
 555       fl1 = NULL;
 556       fl2 = NULL;
 557       for (s = l->equiv; s; s = s->next)
 558         {
 559           if (s->sym == e1->symtree->n.sym)
 560             {
 561               fl1 = s;
 562               if (fl2)
 563                 break;
 564             }
 565           if (s->sym == e2->symtree->n.sym)
 566             {
 567               fl2 = s;
 568               if (fl1)
 569                 break;
 570             }
 571         }
 572
 573       if (s)
 574         {
 575           /* Can these lengths be zero?  */
 576           if (fl1->length <= 0 || fl2->length <= 0)
 577             return 1;
 578           /* These can't overlap if [f11,fl1+length] is before
 579              [fl2,fl2+length], or [fl2,fl2+length] is before
 580              [fl1,fl1+length], otherwise they do overlap.  */
 581           if (fl1->offset + fl1->length > fl2->offset
 582               && fl2->offset + fl2->length > fl1->offset)
 583             return 1;
 584         }
 585     }
 586   return 0;
 587 }
 588
 589
 590 /* Return true if the statement body redefines the condition.  Returns
 591    true if expr2 depends on expr1.  expr1 should be a single term
 592    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 593    whether array references to the same symbol with identical range
 594    references count as a dependency or not.  Used for forall and where
 595    statements.  Also used with functions returning arrays without a
 596    temporary.  */
 597
 598 int
 599 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical)
 600 {
 601   gfc_actual_arglist *actual;
 602   gfc_constructor *c;
 603   gfc_ref *ref;
 604   int n;
 605
 606   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 607
 608   switch (expr2->expr_type)
 609     {
 610     case EXPR_OP:
 611       n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
 612       if (n)
 613         return n;
 614       if (expr2->value.op.op2)
 615         return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
 616       return 0;
 617
 618     case EXPR_VARIABLE:
 619       /* The interesting cases are when the symbols don't match.  */
 620       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 621         {
 622           gfc_typespec *ts1 = &expr1->symtree->n.sym->ts;
 623           gfc_typespec *ts2 = &expr2->symtree->n.sym->ts;
 624
 625           /* Return 1 if expr1 and expr2 are equivalenced arrays.  */
 626           if (gfc_are_equivalenced_arrays (expr1, expr2))
 627             return 1;
 628
 629           /* Symbols can only alias if they have the same type.  */
 630           if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN
 631               && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED)
 632             {
 633               if (ts1->type != ts2->type || ts1->kind != ts2->kind)
 634                 return 0;
 635             }
 636
 637           /* If either variable is a pointer, assume the worst.  */
 638           /* TODO: -fassume-no-pointer-aliasing */
 639           if (expr1->symtree->n.sym->attr.pointer)
 640             return 1;
 641           for (ref = expr1->ref; ref; ref = ref->next)
 642             if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 643               return 1;
 644
 645           if (expr2->symtree->n.sym->attr.pointer)
 646             return 1;
 647           for (ref = expr2->ref; ref; ref = ref->next)
 648             if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 649               return 1;
 650
 651           /* Otherwise distinct symbols have no dependencies.  */
 652           return 0;
 653         }
 654
 655       if (identical)
 656         return 1;
 657
 658       /* Identical and disjoint ranges return 0,
 659          overlapping ranges return 1.  */
 660       if (expr1->ref && expr2->ref)
 661         return gfc_dep_resolver (expr1->ref, expr2->ref);
 662
 663       return 1;
 664
 665     case EXPR_FUNCTION:
 666       if (expr2->inline_noncopying_intrinsic)
 667         identical = 1;
 668       /* Remember possible differences between elemental and
 669          transformational functions.  All functions inside a FORALL
 670          will be pure.  */
 671       for (actual = expr2->value.function.actual;
 672            actual; actual = actual->next)
 673         {
 674           if (!actual->expr)
 675             continue;
 676           n = gfc_check_dependency (expr1, actual->expr, identical);
 677           if (n)
 678             return n;
 679         }
 680       return 0;
 681
 682     case EXPR_CONSTANT:
 683     case EXPR_NULL:
 684       return 0;
 685
 686     case EXPR_ARRAY:
 687       /* Loop through the array constructor's elements.  */
 688       for (c = expr2->value.constructor; c; c = c->next)
 689         {
 690           /* If this is an iterator, assume the worst.  */
 691           if (c->iterator)
 692             return 1;
 693           /* Avoid recursion in the common case.  */
 694           if (c->expr->expr_type == EXPR_CONSTANT)
 695             continue;
 696           if (gfc_check_dependency (expr1, c->expr, 1))
 697             return 1;
 698         }
 699       return 0;
 700
 701     default:
 702       return 1;
 703     }
 704 }
 705
 706
 707 /* Determines overlapping for two array sections.  */
 708
 709 static gfc_dependency
 710 gfc_check_section_vs_section (gfc_ref *lref, gfc_ref *rref, int n)
 711 {
 712   gfc_array_ref l_ar;
 713   gfc_expr *l_start;
 714   gfc_expr *l_end;
 715   gfc_expr *l_stride;
 716   gfc_expr *l_lower;
 717   gfc_expr *l_upper;
 718   int l_dir;
 719
 720   gfc_array_ref r_ar;
 721   gfc_expr *r_start;
 722   gfc_expr *r_end;
 723   gfc_expr *r_stride;
 724   gfc_expr *r_lower;
 725   gfc_expr *r_upper;
 726   int r_dir;
 727
 728   l_ar = lref->u.ar;
 729   r_ar = rref->u.ar;
 730
 731   /* If they are the same range, return without more ado.  */
 732   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 733     return GFC_DEP_EQUAL;
 734
 735   l_start = l_ar.start[n];
 736   l_end = l_ar.end[n];
 737   l_stride = l_ar.stride[n];
 738
 739   r_start = r_ar.start[n];
 740   r_end = r_ar.end[n];
 741   r_stride = r_ar.stride[n];
 742
 743   /* If l_start is NULL take it from array specifier.  */
 744   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as))
 745     l_start = l_ar.as->lower[n];
 746   /* If l_end is NULL take it from array specifier.  */
 747   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as))
 748     l_end = l_ar.as->upper[n];
 749
 750   /* If r_start is NULL take it from array specifier.  */
 751   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 752     r_start = r_ar.as->lower[n];
 753   /* If r_end is NULL take it from array specifier.  */
 754   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 755     r_end = r_ar.as->upper[n];
 756
 757   /* Determine whether the l_stride is positive or negative.  */
 758   if (!l_stride)
 759     l_dir = 1;
 760   else if (l_stride->expr_type == EXPR_CONSTANT
 761            && l_stride->ts.type == BT_INTEGER)
 762     l_dir = mpz_sgn (l_stride->value.integer);
 763   else if (l_start && l_end)
 764     l_dir = gfc_dep_compare_expr (l_end, l_start);
 765   else
 766     l_dir = -2;
 767
 768   /* Determine whether the r_stride is positive or negative.  */
 769   if (!r_stride)
 770     r_dir = 1;
 771   else if (r_stride->expr_type == EXPR_CONSTANT
 772            && r_stride->ts.type == BT_INTEGER)
 773     r_dir = mpz_sgn (r_stride->value.integer);
 774   else if (r_start && r_end)
 775     r_dir = gfc_dep_compare_expr (r_end, r_start);
 776   else
 777     r_dir = -2;
 778
 779   /* The strides should never be zero.  */
 780   if (l_dir == 0 || r_dir == 0)
 781     return GFC_DEP_OVERLAP;
 782
 783   /* Determine LHS upper and lower bounds.  */
 784   if (l_dir == 1)
 785     {
 786       l_lower = l_start;
 787       l_upper = l_end;
 788     }
 789   else if (l_dir == -1)
 790     {
 791       l_lower = l_end;
 792       l_upper = l_start;
 793     }
 794   else
 795     {
 796       l_lower = NULL;
 797       l_upper = NULL;
 798     }
 799
 800   /* Determine RHS upper and lower bounds.  */
 801   if (r_dir == 1)
 802     {
 803       r_lower = r_start;
 804       r_upper = r_end;
 805     }
 806   else if (r_dir == -1)
 807     {
 808       r_lower = r_end;
 809       r_upper = r_start;
 810     }
 811   else
 812     {
 813       r_lower = NULL;
 814       r_upper = NULL;
 815     }
 816
 817   /* Check whether the ranges are disjoint.  */
 818   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
 819     return GFC_DEP_NODEP;
 820   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
 821     return GFC_DEP_NODEP;
 822
 823   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
 824   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
 825     {
 826       if (l_dir == 1 && r_dir == -1)
 827         return GFC_DEP_EQUAL;
 828       if (l_dir == -1 && r_dir == 1)
 829         return GFC_DEP_EQUAL;
 830     }
 831
 832   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
 833   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
 834     {
 835       if (l_dir == 1 && r_dir == -1)
 836         return GFC_DEP_EQUAL;
 837       if (l_dir == -1 && r_dir == 1)
 838         return GFC_DEP_EQUAL;
 839     }
 840
 841   /* Check for forward dependencies x:y vs. x+1:z.  */
 842   if (l_dir == 1 && r_dir == 1
 843       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
 844       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
 845     {
 846       /* Check that the strides are the same.  */
 847       if (!l_stride && !r_stride)
 848         return GFC_DEP_FORWARD;
 849       if (l_stride && r_stride
 850           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 851         return GFC_DEP_FORWARD;
 852     }
 853
 854   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1.  */
 855   if (l_dir == -1 && r_dir == -1
 856       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
 857       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
 858     {
 859       /* Check that the strides are the same.  */
 860       if (!l_stride && !r_stride)
 861         return GFC_DEP_FORWARD;
 862       if (l_stride && r_stride
 863           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 864         return GFC_DEP_FORWARD;
 865     }
 866
 867   return GFC_DEP_OVERLAP;
 868 }
 869
 870
 871 /* Determines overlapping for a single element and a section.  */
 872
 873 static gfc_dependency
 874 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n)
 875 {
 876   gfc_array_ref *ref;
 877   gfc_expr *elem;
 878   gfc_expr *start;
 879   gfc_expr *end;
 880   gfc_expr *stride;
 881   int s;
 882
 883   elem = lref->u.ar.start[n];
 884   if (!elem)
 885     return GFC_DEP_OVERLAP;
 886
 887   ref = &rref->u.ar;
 888   start = ref->start[n] ;
 889   end = ref->end[n] ;
 890   stride = ref->stride[n];
 891
 892   if (!start && IS_ARRAY_EXPLICIT (ref->as))
 893     start = ref->as->lower[n];
 894   if (!end && IS_ARRAY_EXPLICIT (ref->as))
 895     end = ref->as->upper[n];
 896
 897   /* Determine whether the stride is positive or negative.  */
 898   if (!stride)
 899     s = 1;
 900   else if (stride->expr_type == EXPR_CONSTANT
 901            && stride->ts.type == BT_INTEGER)
 902     s = mpz_sgn (stride->value.integer);
 903   else
 904     s = -2;
 905
 906   /* Stride should never be zero.  */
 907   if (s == 0)
 908     return GFC_DEP_OVERLAP;
 909
 910   /* Positive strides.  */
 911   if (s == 1)
 912     {
 913       /* Check for elem < lower.  */
 914       if (start && gfc_dep_compare_expr (elem, start) == -1)
 915         return GFC_DEP_NODEP;
 916       /* Check for elem > upper.  */
 917       if (end && gfc_dep_compare_expr (elem, end) == 1)
 918         return GFC_DEP_NODEP;
 919
 920       if (start && end)
 921         {
 922           s = gfc_dep_compare_expr (start, end);
 923           /* Check for an empty range.  */
 924           if (s == 1)
 925             return GFC_DEP_NODEP;
 926           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
 927             return GFC_DEP_EQUAL;
 928         }
 929     }
 930   /* Negative strides.  */
 931   else if (s == -1)
 932     {
 933       /* Check for elem > upper.  */
 934       if (end && gfc_dep_compare_expr (elem, start) == 1)
 935         return GFC_DEP_NODEP;
 936       /* Check for elem < lower.  */
 937       if (start && gfc_dep_compare_expr (elem, end) == -1)
 938         return GFC_DEP_NODEP;
 939
 940       if (start && end)
 941         {
 942           s = gfc_dep_compare_expr (start, end);
 943           /* Check for an empty range.  */
 944           if (s == -1)
 945             return GFC_DEP_NODEP;
 946           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
 947             return GFC_DEP_EQUAL;
 948         }
 949     }
 950   /* Unknown strides.  */
 951   else
 952     {
 953       if (!start || !end)
 954         return GFC_DEP_OVERLAP;
 955       s = gfc_dep_compare_expr (start, end);
 956       if (s == -2)
 957         return GFC_DEP_OVERLAP;
 958       /* Assume positive stride.  */
 959       if (s == -1)
 960         {
 961           /* Check for elem < lower.  */
 962           if (gfc_dep_compare_expr (elem, start) == -1)
 963             return GFC_DEP_NODEP;
 964           /* Check for elem > upper.  */
 965           if (gfc_dep_compare_expr (elem, end) == 1)
 966             return GFC_DEP_NODEP;
 967         }
 968       /* Assume negative stride.  */
 969       else if (s == 1)
 970         {
 971           /* Check for elem > upper.  */
 972           if (gfc_dep_compare_expr (elem, start) == 1)
 973             return GFC_DEP_NODEP;
 974           /* Check for elem < lower.  */
 975           if (gfc_dep_compare_expr (elem, end) == -1)
 976             return GFC_DEP_NODEP;
 977         }
 978       /* Equal bounds.  */
 979       else if (s == 0)
 980         {
 981           s = gfc_dep_compare_expr (elem, start);
 982           if (s == 0)
 983             return GFC_DEP_EQUAL;
 984           if (s == 1 || s == -1)
 985             return GFC_DEP_NODEP;
 986         }
 987     }
 988
 989   return GFC_DEP_OVERLAP;
 990 }
 991
 992
 993 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
 994    forall_index attribute.  Return true if any variable may be
 995    being used as a FORALL index.  Its safe to pessimistically
 996    return true, and assume a dependency.  */
 997
 998 static bool
 999 contains_forall_index_p (gfc_expr *expr)
1000 {
1001   gfc_actual_arglist *arg;
1002   gfc_constructor *c;
1003   gfc_ref *ref;
1004   int i;
1005
1006   if (!expr)
1007     return false;
1008
1009   switch (expr->expr_type)
1010     {
1011     case EXPR_VARIABLE:
1012       if (expr->symtree->n.sym->forall_index)
1013         return true;
1014       break;
1015
1016     case EXPR_OP:
1017       if (contains_forall_index_p (expr->value.op.op1)
1018           || contains_forall_index_p (expr->value.op.op2))
1019         return true;
1020       break;
1021
1022     case EXPR_FUNCTION:
1023       for (arg = expr->value.function.actual; arg; arg = arg->next)
1024         if (contains_forall_index_p (arg->expr))
1025           return true;
1026       break;
1027
1028     case EXPR_CONSTANT:
1029     case EXPR_NULL:
1030     case EXPR_SUBSTRING:
1031       break;
1032
1033     case EXPR_STRUCTURE:
1034     case EXPR_ARRAY:
1035       for (c = expr->value.constructor; c; c = c->next)
1036         if (contains_forall_index_p (c->expr))
1037           return true;
1038       break;
1039
1040     default:
1041       gcc_unreachable ();
1042     }
1043
1044   for (ref = expr->ref; ref; ref = ref->next)
1045     switch (ref->type)
1046       {
1047       case REF_ARRAY:
1048         for (i = 0; i < ref->u.ar.dimen; i++)
1049           if (contains_forall_index_p (ref->u.ar.start[i])
1050               || contains_forall_index_p (ref->u.ar.end[i])
1051               || contains_forall_index_p (ref->u.ar.stride[i]))
1052             return true;
1053         break;
1054
1055       case REF_COMPONENT:
1056         break;
1057
1058       case REF_SUBSTRING:
1059         if (contains_forall_index_p (ref->u.ss.start)
1060             || contains_forall_index_p (ref->u.ss.end))
1061           return true;
1062         break;
1063
1064       default:
1065         gcc_unreachable ();
1066       }
1067
1068   return false;
1069 }
1070
1071 /* Determines overlapping for two single element array references.  */
1072
1073 static gfc_dependency
1074 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n)
1075 {
1076   gfc_array_ref l_ar;
1077   gfc_array_ref r_ar;
1078   gfc_expr *l_start;
1079   gfc_expr *r_start;
1080   int i;
1081
1082   l_ar = lref->u.ar;
1083   r_ar = rref->u.ar;
1084   l_start = l_ar.start[n] ;
1085   r_start = r_ar.start[n] ;
1086   i = gfc_dep_compare_expr (r_start, l_start);
1087   if (i == 0)
1088     return GFC_DEP_EQUAL;
1089
1090   /* Treat two scalar variables as potentially equal.  This allows
1091      us to prove that a(i,:) and a(j,:) have no dependency.  See
1092      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1093      Proceedings of the International Conference on Parallel and
1094      Distributed Processing Techniques and Applications (PDPTA2001),
1095      Las Vegas, Nevada, June 2001.  */
1096   /* However, we need to be careful when either scalar expression
1097      contains a FORALL index, as these can potentially change value
1098      during the scalarization/traversal of this array reference.  */
1099   if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start))
1100     return GFC_DEP_OVERLAP;
1101
1102   if (i != -2)
1103     return GFC_DEP_NODEP;
1104   return GFC_DEP_EQUAL;
1105 }
1106
1107
1108 /* Determine if an array ref, usually an array section specifies the
1109    entire array.  */
1110
1111 bool
1112 gfc_full_array_ref_p (gfc_ref *ref)
1113 {
1114   int i;
1115
1116   if (ref->type != REF_ARRAY)
1117     return false;
1118   if (ref->u.ar.type == AR_FULL)
1119     return true;
1120   if (ref->u.ar.type != AR_SECTION)
1121     return false;
1122   if (ref->next)
1123     return false;
1124
1125   for (i = 0; i < ref->u.ar.dimen; i++)
1126     {
1127       /* If we have a single element in the reference, we need to check
1128          that the array has a single element and that we actually reference
1129          the correct element.  */
1130       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT)
1131         {
1132           if (!ref->u.ar.as
1133               || !ref->u.ar.as->lower[i]
1134               || !ref->u.ar.as->upper[i]
1135               || gfc_dep_compare_expr (ref->u.ar.as->lower[i],
1136                                        ref->u.ar.as->upper[i])
1137               || !ref->u.ar.start[i]
1138               || gfc_dep_compare_expr (ref->u.ar.start[i],
1139                                        ref->u.ar.as->lower[i]))
1140             return false;
1141           else
1142             continue;
1143         }
1144
1145       /* Check the lower bound.  */
1146       if (ref->u.ar.start[i]
1147           && (!ref->u.ar.as
1148               || !ref->u.ar.as->lower[i]
1149               || gfc_dep_compare_expr (ref->u.ar.start[i],
1150                                        ref->u.ar.as->lower[i])))
1151         return false;
1152       /* Check the upper bound.  */
1153       if (ref->u.ar.end[i]
1154           && (!ref->u.ar.as
1155               || !ref->u.ar.as->upper[i]
1156               || gfc_dep_compare_expr (ref->u.ar.end[i],
1157                                        ref->u.ar.as->upper[i])))
1158         return false;
1159       /* Check the stride.  */
1160       if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0))
1161         return false;
1162     }
1163   return true;
1164 }
1165
1166
1167 /* Finds if two array references are overlapping or not.
1168    Return value
1169         1 : array references are overlapping.
1170         0 : array references are identical or not overlapping.  */
1171
1172 int
1173 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref)
1174 {
1175   int n;
1176   gfc_dependency fin_dep;
1177   gfc_dependency this_dep;
1178
1179   fin_dep = GFC_DEP_ERROR;
1180   /* Dependencies due to pointers should already have been identified.
1181      We only need to check for overlapping array references.  */
1182
1183   while (lref && rref)
1184     {
1185       /* We're resolving from the same base symbol, so both refs should be
1186          the same type.  We traverse the reference chain intil we find ranges
1187          that are not equal.  */
1188       gcc_assert (lref->type == rref->type);
1189       switch (lref->type)
1190         {
1191         case REF_COMPONENT:
1192           /* The two ranges can't overlap if they are from different
1193              components.  */
1194           if (lref->u.c.component != rref->u.c.component)
1195             return 0;
1196           break;
1197
1198         case REF_SUBSTRING:
1199           /* Substring overlaps are handled by the string assignment code
1200              if there is not an underlying dependency.  */
1201           return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
1202
1203         case REF_ARRAY:
1204           if (lref->u.ar.dimen != rref->u.ar.dimen)
1205             {
1206               if (lref->u.ar.type == AR_FULL)
1207                 fin_dep = gfc_full_array_ref_p (rref) ? GFC_DEP_EQUAL
1208                                                       : GFC_DEP_OVERLAP;
1209               else if (rref->u.ar.type == AR_FULL)
1210                 fin_dep = gfc_full_array_ref_p (lref) ? GFC_DEP_EQUAL
1211                                                       : GFC_DEP_OVERLAP;
1212               else
1213                 return 1;
1214               break;
1215             }
1216
1217           for (n=0; n < lref->u.ar.dimen; n++)
1218             {
1219               /* Assume dependency when either of array reference is vector
1220                  subscript.  */
1221               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1222                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1223                 return 1;
1224               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1225                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1226                 this_dep = gfc_check_section_vs_section (lref, rref, n);
1227               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1228                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1229                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1230               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1231                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1232                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1233               else
1234                 {
1235                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1236                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1237                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1238                 }
1239
1240               /* If any dimension doesn't overlap, we have no dependency.  */
1241               if (this_dep == GFC_DEP_NODEP)
1242                 return 0;
1243
1244               /* Overlap codes are in order of priority.  We only need to
1245                  know the worst one.*/
1246               if (this_dep > fin_dep)
1247                 fin_dep = this_dep;
1248             }
1249           /* Exactly matching and forward overlapping ranges don't cause a
1250              dependency.  */
1251           if (fin_dep < GFC_DEP_OVERLAP)
1252             return 0;
1253
1254           /* Keep checking.  We only have a dependency if
1255              subsequent references also overlap.  */
1256           break;
1257
1258         default:
1259           gcc_unreachable ();
1260         }
1261       lref = lref->next;
1262       rref = rref->next;
1263     }
1264
1265   /* If we haven't seen any array refs then something went wrong.  */
1266   gcc_assert (fin_dep != GFC_DEP_ERROR);
1267
1268   /* Assume the worst if we nest to different depths.  */
1269   if (lref || rref)
1270     return 1;
1271
1272   return fin_dep == GFC_DEP_OVERLAP;
1273 }
1274