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