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