gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005, 2006 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  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
  28 #include "config.h"
  29 #include "gfortran.h"
  30 #include "dependency.h"
  31
  32 /* static declarations */
  33 /* Enums  */
  34 enum range {LHS, RHS, MID};
  35
  36 /* Dependency types.  These must be in reverse order of priority.  */
  37 typedef enum
  38 {
  39   GFC_DEP_ERROR,
  40   GFC_DEP_EQUAL,        /* Identical Ranges.  */
  41   GFC_DEP_FORWARD,      /* eg. a(1:3), a(2:4).  */
  42   GFC_DEP_OVERLAP,      /* May overlap in some other way.  */
  43   GFC_DEP_NODEP         /* Distinct ranges.  */
  44 }
  45 gfc_dependency;
  46
  47 /* Macros */
  48 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0))
  49
  50
  51 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or
  52    def if the value could not be determined.  */
  53
  54 int
  55 gfc_expr_is_one (gfc_expr * expr, int def)
  56 {
  57   gcc_assert (expr != NULL);
  58
  59   if (expr->expr_type != EXPR_CONSTANT)
  60     return def;
  61
  62   if (expr->ts.type != BT_INTEGER)
  63     return def;
  64
  65   return mpz_cmp_si (expr->value.integer, 1) == 0;
  66 }
  67
  68
  69 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
  70    and -2 if the relationship could not be determined.  */
  71
  72 int
  73 gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2)
  74 {
  75   gfc_actual_arglist *args1;
  76   gfc_actual_arglist *args2;
  77   int i;
  78
  79   if (e1->expr_type == EXPR_OP
  80       && (e1->value.op.operator == INTRINSIC_UPLUS
  81           || e1->value.op.operator == INTRINSIC_PARENTHESES))
  82     return gfc_dep_compare_expr (e1->value.op.op1, e2);
  83   if (e2->expr_type == EXPR_OP
  84       && (e2->value.op.operator == INTRINSIC_UPLUS
  85           || e2->value.op.operator == INTRINSIC_PARENTHESES))
  86     return gfc_dep_compare_expr (e1, e2->value.op.op1);
  87
  88   if (e1->expr_type == EXPR_OP
  89       && e1->value.op.operator == INTRINSIC_PLUS)
  90     {
  91       /* Compare X+C vs. X.  */
  92       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
  93           && e1->value.op.op2->ts.type == BT_INTEGER
  94           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
  95         return mpz_sgn (e1->value.op.op2->value.integer);
  96
  97       /* Compare P+Q vs. R+S.  */
  98       if (e2->expr_type == EXPR_OP
  99           && e2->value.op.operator == INTRINSIC_PLUS)
 100         {
 101           int l, r;
 102
 103           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 104           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 105           if (l == 0 && r == 0)
 106             return 0;
 107           if (l == 0 && r != -2)
 108             return r;
 109           if (l != -2 && r == 0)
 110             return l;
 111           if (l == 1 && r == 1)
 112             return 1;
 113           if (l == -1 && r == -1)
 114             return -1;
 115
 116           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2);
 117           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1);
 118           if (l == 0 && r == 0)
 119             return 0;
 120           if (l == 0 && r != -2)
 121             return r;
 122           if (l != -2 && r == 0)
 123             return l;
 124           if (l == 1 && r == 1)
 125             return 1;
 126           if (l == -1 && r == -1)
 127             return -1;
 128         }
 129     }
 130
 131   /* Compare X vs. X+C.  */
 132   if (e2->expr_type == EXPR_OP
 133       && e2->value.op.operator == INTRINSIC_PLUS)
 134     {
 135       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 136           && e2->value.op.op2->ts.type == BT_INTEGER
 137           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 138         return -mpz_sgn (e2->value.op.op2->value.integer);
 139     }
 140
 141   /* Compare X-C vs. X.  */
 142   if (e1->expr_type == EXPR_OP
 143       && e1->value.op.operator == INTRINSIC_MINUS)
 144     {
 145       if (e1->value.op.op2->expr_type == EXPR_CONSTANT
 146           && e1->value.op.op2->ts.type == BT_INTEGER
 147           && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0)
 148         return -mpz_sgn (e1->value.op.op2->value.integer);
 149
 150       /* Compare P-Q vs. R-S.  */
 151       if (e2->expr_type == EXPR_OP
 152           && e2->value.op.operator == INTRINSIC_MINUS)
 153         {
 154           int l, r;
 155
 156           l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 157           r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2);
 158           if (l == 0 && r == 0)
 159             return 0;
 160           if (l != -2 && r == 0)
 161             return l;
 162           if (l == 0 && r != -2)
 163             return -r;
 164           if (l == 1 && r == -1)
 165             return 1;
 166           if (l == -1 && r == 1)
 167             return -1;
 168         }
 169     }
 170
 171   /* Compare X vs. X-C.  */
 172   if (e2->expr_type == EXPR_OP
 173       && e2->value.op.operator == INTRINSIC_MINUS)
 174     {
 175       if (e2->value.op.op2->expr_type == EXPR_CONSTANT
 176           && e2->value.op.op2->ts.type == BT_INTEGER
 177           && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0)
 178         return mpz_sgn (e2->value.op.op2->value.integer);
 179     }
 180
 181   if (e1->expr_type != e2->expr_type)
 182     return -2;
 183
 184   switch (e1->expr_type)
 185     {
 186     case EXPR_CONSTANT:
 187       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
 188         return -2;
 189
 190       i = mpz_cmp (e1->value.integer, e2->value.integer);
 191       if (i == 0)
 192         return 0;
 193       else if (i < 0)
 194         return -1;
 195       return 1;
 196
 197     case EXPR_VARIABLE:
 198       if (e1->ref || e2->ref)
 199         return -2;
 200       if (e1->symtree->n.sym == e2->symtree->n.sym)
 201         return 0;
 202       return -2;
 203
 204     case EXPR_OP:
 205       /* Intrinsic operators are the same if their operands are the same.  */
 206       if (e1->value.op.operator != e2->value.op.operator)
 207         return -2;
 208       if (e1->value.op.op2 == 0)
 209         {
 210           i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1);
 211           return i == 0 ? 0 : -2;
 212         }
 213       if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0
 214           && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0)
 215         return 0;
 216       /* TODO Handle commutative binary operators here?  */
 217       return -2;
 218
 219     case EXPR_FUNCTION:
 220       /* We can only compare calls to the same intrinsic function.  */
 221       if (e1->value.function.isym == 0
 222           || e2->value.function.isym == 0
 223           || e1->value.function.isym != e2->value.function.isym)
 224         return -2;
 225
 226       args1 = e1->value.function.actual;
 227       args2 = e2->value.function.actual;
 228
 229       /* We should list the "constant" intrinsic functions.  Those
 230          without side-effects that provide equal results given equal
 231          argument lists.  */
 232       switch (e1->value.function.isym->generic_id)
 233         {
 234         case GFC_ISYM_CONVERSION:
 235           /* Handle integer extensions specially, as __convert_i4_i8
 236              is not only "constant" but also "unary" and "increasing".  */
 237           if (args1 && !args1->next
 238               && args2 && !args2->next
 239               && e1->ts.type == BT_INTEGER
 240               && args1->expr->ts.type == BT_INTEGER
 241               && e1->ts.kind > args1->expr->ts.kind
 242               && e2->ts.type == e1->ts.type
 243               && e2->ts.kind == e1->ts.kind
 244               && args2->expr->ts.type == args1->expr->ts.type
 245               && args2->expr->ts.kind == args2->expr->ts.kind)
 246             return gfc_dep_compare_expr (args1->expr, args2->expr);
 247           break;
 248
 249         case GFC_ISYM_REAL:
 250         case GFC_ISYM_LOGICAL:
 251         case GFC_ISYM_DBLE:
 252           break;
 253
 254         default:
 255           return -2;
 256         }
 257
 258       /* Compare the argument lists for equality.  */
 259       while (args1 && args2)
 260         {
 261           if (gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
 262             return -2;
 263           args1 = args1->next;
 264           args2 = args2->next;
 265         }
 266       return (args1 || args2) ? -2 : 0;
 267
 268     default:
 269       return -2;
 270     }
 271 }
 272
 273
 274 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 275    if the results are indeterminate.  N is the dimension to compare.  */
 276
 277 int
 278 gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
 279 {
 280   gfc_expr *e1;
 281   gfc_expr *e2;
 282   int i;
 283
 284   /* TODO: More sophisticated range comparison.  */
 285   gcc_assert (ar1 && ar2);
 286
 287   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 288
 289   e1 = ar1->stride[n];
 290   e2 = ar2->stride[n];
 291   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 292   if (e1 && !e2)
 293     {
 294       i = gfc_expr_is_one (e1, -1);
 295       if (i == -1)
 296         return def;
 297       else if (i == 0)
 298         return 0;
 299     }
 300   else if (e2 && !e1)
 301     {
 302       i = gfc_expr_is_one (e2, -1);
 303       if (i == -1)
 304         return def;
 305       else if (i == 0)
 306         return 0;
 307     }
 308   else if (e1 && e2)
 309     {
 310       i = gfc_dep_compare_expr (e1, e2);
 311       if (i == -2)
 312         return def;
 313       else if (i != 0)
 314         return 0;
 315     }
 316   /* The strides match.  */
 317
 318   /* Check the range start.  */
 319   e1 = ar1->start[n];
 320   e2 = ar2->start[n];
 321   if (e1 || e2)
 322     {
 323       /* Use the bound of the array if no bound is specified.  */
 324       if (ar1->as && !e1)
 325         e1 = ar1->as->lower[n];
 326
 327       if (ar2->as && !e2)
 328         e2 = ar2->as->lower[n];
 329
 330       /* Check we have values for both.  */
 331       if (!(e1 && e2))
 332         return def;
 333
 334       i = gfc_dep_compare_expr (e1, e2);
 335       if (i == -2)
 336         return def;
 337       else if (i != 0)
 338         return 0;
 339     }
 340
 341   /* Check the range end.  */
 342   e1 = ar1->end[n];
 343   e2 = ar2->end[n];
 344   if (e1 || e2)
 345     {
 346       /* Use the bound of the array if no bound is specified.  */
 347       if (ar1->as && !e1)
 348         e1 = ar1->as->upper[n];
 349
 350       if (ar2->as && !e2)
 351         e2 = ar2->as->upper[n];
 352
 353       /* Check we have values for both.  */
 354       if (!(e1 && e2))
 355         return def;
 356
 357       i = gfc_dep_compare_expr (e1, e2);
 358       if (i == -2)
 359         return def;
 360       else if (i != 0)
 361         return 0;
 362     }
 363
 364   return 1;
 365 }
 366
 367
 368 /* Some array-returning intrinsics can be implemented by reusing the
 369    data from one of the array arguments.  For example, TRANSPOSE does
 370    not necessarily need to allocate new data: it can be implemented
 371    by copying the original array's descriptor and simply swapping the
 372    two dimension specifications.
 373
 374    If EXPR is a call to such an intrinsic, return the argument
 375    whose data can be reused, otherwise return NULL.  */
 376
 377 gfc_expr *
 378 gfc_get_noncopying_intrinsic_argument (gfc_expr * expr)
 379 {
 380   if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym)
 381     return NULL;
 382
 383   switch (expr->value.function.isym->generic_id)
 384     {
 385     case GFC_ISYM_TRANSPOSE:
 386       return expr->value.function.actual->expr;
 387
 388     default:
 389       return NULL;
 390     }
 391 }
 392
 393
 394 /* Return true if the result of reference REF can only be constructed
 395    using a temporary array.  */
 396
 397 bool
 398 gfc_ref_needs_temporary_p (gfc_ref *ref)
 399 {
 400   int n;
 401   bool subarray_p;
 402
 403   subarray_p = false;
 404   for (; ref; ref = ref->next)
 405     switch (ref->type)
 406       {
 407       case REF_ARRAY:
 408         /* Vector dimensions are generally not monotonic and must be
 409            handled using a temporary.  */
 410         if (ref->u.ar.type == AR_SECTION)
 411           for (n = 0; n < ref->u.ar.dimen; n++)
 412             if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 413               return true;
 414
 415         subarray_p = true;
 416         break;
 417
 418       case REF_SUBSTRING:
 419         /* Within an array reference, character substrings generally
 420            need a temporary.  Character array strides are expressed as
 421            multiples of the element size (consistent with other array
 422            types), not in characters.  */
 423         return subarray_p;
 424
 425       case REF_COMPONENT:
 426         break;
 427       }
 428
 429   return false;
 430 }
 431
 432
 433 /* Return true if array variable VAR could be passed to the same function
 434    as argument EXPR without interfering with EXPR.  INTENT is the intent
 435    of VAR.
 436
 437    This is considerably less conservative than other dependencies
 438    because many function arguments will already be copied into a
 439    temporary.  */
 440
 441 static int
 442 gfc_check_argument_var_dependency (gfc_expr * var, sym_intent intent,
 443                                    gfc_expr * expr)
 444 {
 445   gcc_assert (var->expr_type == EXPR_VARIABLE);
 446   gcc_assert (var->rank > 0);
 447
 448   switch (expr->expr_type)
 449     {
 450     case EXPR_VARIABLE:
 451       return (gfc_ref_needs_temporary_p (expr->ref)
 452               || gfc_check_dependency (var, expr, 1));
 453
 454     case EXPR_ARRAY:
 455       return gfc_check_dependency (var, expr, 1);
 456
 457     case EXPR_FUNCTION:
 458       if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
 459         {
 460           expr = gfc_get_noncopying_intrinsic_argument (expr);
 461           return gfc_check_argument_var_dependency (var, intent, expr);
 462         }
 463       return 0;
 464
 465     default:
 466       return 0;
 467     }
 468 }
 469
 470
 471 /* Like gfc_check_argument_var_dependency, but extended to any
 472    array expression OTHER, not just variables.  */
 473
 474 static int
 475 gfc_check_argument_dependency (gfc_expr * other, sym_intent intent,
 476                                gfc_expr * expr)
 477 {
 478   switch (other->expr_type)
 479     {
 480     case EXPR_VARIABLE:
 481       return gfc_check_argument_var_dependency (other, intent, expr);
 482
 483     case EXPR_FUNCTION:
 484       if (other->inline_noncopying_intrinsic)
 485         {
 486           other = gfc_get_noncopying_intrinsic_argument (other);
 487           return gfc_check_argument_dependency (other, INTENT_IN, expr);
 488         }
 489       return 0;
 490
 491     default:
 492       return 0;
 493     }
 494 }
 495
 496
 497 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL.
 498    FNSYM is the function being called, or NULL if not known.  */
 499
 500 int
 501 gfc_check_fncall_dependency (gfc_expr * other, sym_intent intent,
 502                              gfc_symbol * fnsym, gfc_actual_arglist * actual)
 503 {
 504   gfc_formal_arglist *formal;
 505   gfc_expr *expr;
 506
 507   formal = fnsym ? fnsym->formal : NULL;
 508   for (; actual; actual = actual->next, formal = formal ? formal->next : NULL)
 509     {
 510       expr = actual->expr;
 511
 512       /* Skip args which are not present.  */
 513       if (!expr)
 514         continue;
 515
 516       /* Skip intent(in) arguments if OTHER itself is intent(in).  */
 517       if (formal
 518           && intent == INTENT_IN
 519           && formal->sym->attr.intent == INTENT_IN)
 520         continue;
 521
 522       if (gfc_check_argument_dependency (other, intent, expr))
 523         return 1;
 524     }
 525
 526   return 0;
 527 }
 528
 529
 530 /* Return 1 if e1 and e2 are equivalenced arrays, either
 531    directly or indirectly; ie. equivalence (a,b) for a and b
 532    or equivalence (a,c),(b,c).  This function uses the equiv_
 533    lists, generated in trans-common(add_equivalences), that are
 534    guaranteed to pick up indirect equivalences.  We explicitly
 535    check for overlap using the offset and length of the equivalence.
 536    This function is symmetric.
 537    TODO: This function only checks whether the full top-level
 538    symbols overlap.  An improved implementation could inspect
 539    e1->ref and e2->ref to determine whether the actually accessed
 540    portions of these variables/arrays potentially overlap.  */
 541
 542 int
 543 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
 544 {
 545   gfc_equiv_list *l;
 546   gfc_equiv_info *s, *fl1, *fl2;
 547
 548   gcc_assert (e1->expr_type == EXPR_VARIABLE
 549                 && e2->expr_type == EXPR_VARIABLE);
 550
 551   if (!e1->symtree->n.sym->attr.in_equivalence
 552         || !e2->symtree->n.sym->attr.in_equivalence
 553         || !e1->rank
 554         || !e2->rank)
 555     return 0;
 556
 557   /* Go through the equiv_lists and return 1 if the variables
 558      e1 and e2 are members of the same group and satisfy the
 559      requirement on their relative offsets.  */
 560   for (l = gfc_current_ns->equiv_lists; l; l = l->next)
 561     {
 562       fl1 = NULL;
 563       fl2 = NULL;
 564       for (s = l->equiv; s; s = s->next)
 565         {
 566           if (s->sym == e1->symtree->n.sym)
 567             {
 568               fl1 = s;
 569               if (fl2)
 570                 break;
 571             }
 572           if (s->sym == e2->symtree->n.sym)
 573             {
 574               fl2 = s;
 575               if (fl1)
 576                 break;
 577             }
 578         }
 579
 580       if (s)
 581         {
 582           /* Can these lengths be zero?  */
 583           if (fl1->length <= 0 || fl2->length <= 0)
 584             return 1;
 585           /* These can't overlap if [f11,fl1+length] is before
 586              [fl2,fl2+length], or [fl2,fl2+length] is before
 587              [fl1,fl1+length], otherwise they do overlap.  */
 588           if (fl1->offset + fl1->length > fl2->offset
 589               && fl2->offset + fl2->length > fl1->offset)
 590             return 1;
 591         }
 592     }
 593   return 0;
 594 }
 595
 596
 597 /* Return true if the statement body redefines the condition.  Returns
 598    true if expr2 depends on expr1.  expr1 should be a single term
 599    suitable for the lhs of an assignment.  The IDENTICAL flag indicates
 600    whether array references to the same symbol with identical range
 601    references count as a dependency or not.  Used for forall and where
 602    statements.  Also used with functions returning arrays without a
 603    temporary.  */
 604
 605 int
 606 gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
 607 {
 608   gfc_ref *ref;
 609   int n;
 610   gfc_actual_arglist *actual;
 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
 637               && ts2->type != BT_UNKNOWN
 638               && ts1->type != BT_DERIVED
 639               && ts2->type != BT_DERIVED)
 640             {
 641               if (ts1->type != ts2->type
 642                   || ts1->kind != ts2->kind)
 643                 return 0;
 644             }
 645
 646           /* If either variable is a pointer, assume the worst.  */
 647           /* TODO: -fassume-no-pointer-aliasing */
 648           if (expr1->symtree->n.sym->attr.pointer)
 649             return 1;
 650           for (ref = expr1->ref; ref; ref = ref->next)
 651             if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 652               return 1;
 653
 654           if (expr2->symtree->n.sym->attr.pointer)
 655             return 1;
 656           for (ref = expr2->ref; ref; ref = ref->next)
 657             if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 658               return 1;
 659
 660           /* Otherwise distinct symbols have no dependencies.  */
 661           return 0;
 662         }
 663
 664       if (identical)
 665         return 1;
 666
 667       /* Identical and disjoint ranges return 0,
 668          overlapping ranges return 1.  */
 669       /* Return zero if we refer to the same full arrays.  */
 670       if (expr1->ref->type == REF_ARRAY && expr2->ref->type == REF_ARRAY)
 671         return gfc_dep_resolver (expr1->ref, expr2->ref);
 672
 673       return 1;
 674
 675     case EXPR_FUNCTION:
 676       if (expr2->inline_noncopying_intrinsic)
 677         identical = 1;
 678       /* Remember possible differences between elemental and
 679          transformational functions.  All functions inside a FORALL
 680          will be pure.  */
 681       for (actual = expr2->value.function.actual;
 682            actual; actual = actual->next)
 683         {
 684           if (!actual->expr)
 685             continue;
 686           n = gfc_check_dependency (expr1, actual->expr, identical);
 687           if (n)
 688             return n;
 689         }
 690       return 0;
 691
 692     case EXPR_CONSTANT:
 693       return 0;
 694
 695     case EXPR_ARRAY:
 696       /* Probably ok in the majority of (constant) cases.  */
 697       return 1;
 698
 699     default:
 700       return 1;
 701     }
 702 }
 703
 704
 705 /* Determines overlapping for two array sections.  */
 706
 707 static gfc_dependency
 708 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 709 {
 710   gfc_array_ref l_ar;
 711   gfc_expr *l_start;
 712   gfc_expr *l_end;
 713   gfc_expr *l_stride;
 714   gfc_expr *l_lower;
 715   gfc_expr *l_upper;
 716   int l_dir;
 717
 718   gfc_array_ref r_ar;
 719   gfc_expr *r_start;
 720   gfc_expr *r_end;
 721   gfc_expr *r_stride;
 722   gfc_expr *r_lower;
 723   gfc_expr *r_upper;
 724   int r_dir;
 725
 726   l_ar = lref->u.ar;
 727   r_ar = rref->u.ar;
 728
 729   /* If they are the same range, return without more ado.  */
 730   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 731     return GFC_DEP_EQUAL;
 732
 733   l_start = l_ar.start[n];
 734   l_end = l_ar.end[n];
 735   l_stride = l_ar.stride[n];
 736
 737   r_start = r_ar.start[n];
 738   r_end = r_ar.end[n];
 739   r_stride = r_ar.stride[n];
 740
 741   /* If l_start is NULL take it from array specifier.  */
 742   if (NULL == l_start && IS_ARRAY_EXPLICIT (l_ar.as))
 743     l_start = l_ar.as->lower[n];
 744   /* If l_end is NULL take it from array specifier.  */
 745   if (NULL == l_end && IS_ARRAY_EXPLICIT (l_ar.as))
 746     l_end = l_ar.as->upper[n];
 747
 748   /* If r_start is NULL take it from array specifier.  */
 749   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 750     r_start = r_ar.as->lower[n];
 751   /* If r_end is NULL take it from array specifier.  */
 752   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 753     r_end = r_ar.as->upper[n];
 754
 755   /* Determine whether the l_stride is positive or negative.  */
 756   if (!l_stride)
 757     l_dir = 1;
 758   else if (l_stride->expr_type == EXPR_CONSTANT
 759            && l_stride->ts.type == BT_INTEGER)
 760     l_dir = mpz_sgn (l_stride->value.integer);
 761   else if (l_start && l_end)
 762     l_dir = gfc_dep_compare_expr (l_end, l_start);
 763   else
 764     l_dir = -2;
 765
 766   /* Determine whether the r_stride is positive or negative.  */
 767   if (!r_stride)
 768     r_dir = 1;
 769   else if (r_stride->expr_type == EXPR_CONSTANT
 770            && r_stride->ts.type == BT_INTEGER)
 771     r_dir = mpz_sgn (r_stride->value.integer);
 772   else if (r_start && r_end)
 773     r_dir = gfc_dep_compare_expr (r_end, r_start);
 774   else
 775     r_dir = -2;
 776
 777   /* The strides should never be zero.  */
 778   if (l_dir == 0 || r_dir == 0)
 779     return GFC_DEP_OVERLAP;
 780
 781   /* Determine LHS upper and lower bounds.  */
 782   if (l_dir == 1)
 783     {
 784       l_lower = l_start;
 785       l_upper = l_end;
 786     }
 787   else if (l_dir == -1)
 788     {
 789       l_lower = l_end;
 790       l_upper = l_start;
 791     }
 792   else
 793     {
 794       l_lower = NULL;
 795       l_upper = NULL;
 796     }
 797
 798   /* Determine RHS upper and lower bounds.  */
 799   if (r_dir == 1)
 800     {
 801       r_lower = r_start;
 802       r_upper = r_end;
 803     }
 804   else if (r_dir == -1)
 805     {
 806       r_lower = r_end;
 807       r_upper = r_start;
 808     }
 809   else
 810     {
 811       r_lower = NULL;
 812       r_upper = NULL;
 813     }
 814
 815   /* Check whether the ranges are disjoint.  */
 816   if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1)
 817     return GFC_DEP_NODEP;
 818   if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1)
 819     return GFC_DEP_NODEP;
 820
 821   /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL.  */
 822   if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0)
 823     {
 824       if (l_dir == 1 && r_dir == -1)
 825         return GFC_DEP_EQUAL;
 826       if (l_dir == -1 && r_dir == 1)
 827         return GFC_DEP_EQUAL;
 828     }
 829
 830   /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL.  */
 831   if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0)
 832     {
 833       if (l_dir == 1 && r_dir == -1)
 834         return GFC_DEP_EQUAL;
 835       if (l_dir == -1 && r_dir == 1)
 836         return GFC_DEP_EQUAL;
 837     }
 838
 839   /* Check for forward dependencies x:y vs. x+1:z.  */
 840   if (l_dir == 1 && r_dir == 1
 841       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == -1
 842       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == -1)
 843     {
 844       /* Check that the strides are the same.  */
 845       if (!l_stride && !r_stride)
 846         return GFC_DEP_FORWARD;
 847       if (l_stride && r_stride
 848           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 849         return GFC_DEP_FORWARD;
 850     }
 851
 852   /* Check for forward dependencies x:y:-1 vs. x-1:z:-1.  */
 853   if (l_dir == -1 && r_dir == -1
 854       && l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 1
 855       && l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 1)
 856     {
 857       /* Check that the strides are the same.  */
 858       if (!l_stride && !r_stride)
 859         return GFC_DEP_FORWARD;
 860       if (l_stride && r_stride
 861           && gfc_dep_compare_expr (l_stride, r_stride) == 0)
 862         return GFC_DEP_FORWARD;
 863     }
 864
 865   return GFC_DEP_OVERLAP;
 866 }
 867
 868
 869 /* Determines overlapping for a single element and a section.  */
 870
 871 static gfc_dependency
 872 gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
 873 {
 874   gfc_array_ref *ref;
 875   gfc_expr *elem;
 876   gfc_expr *start;
 877   gfc_expr *end;
 878   gfc_expr *stride;
 879   int s;
 880
 881   elem = lref->u.ar.start[n];
 882   if (!elem)
 883     return GFC_DEP_OVERLAP;
 884
 885   ref = &rref->u.ar;
 886   start = ref->start[n] ;
 887   end = ref->end[n] ;
 888   stride = ref->stride[n];
 889
 890   if (!start && IS_ARRAY_EXPLICIT (ref->as))
 891     start = ref->as->lower[n];
 892   if (!end && IS_ARRAY_EXPLICIT (ref->as))
 893     end = ref->as->upper[n];
 894
 895   /* Determine whether the stride is positive or negative.  */
 896   if (!stride)
 897     s = 1;
 898   else if (stride->expr_type == EXPR_CONSTANT
 899            && stride->ts.type == BT_INTEGER)
 900     s = mpz_sgn (stride->value.integer);
 901   else
 902     s = -2;
 903
 904   /* Stride should never be zero.  */
 905   if (s == 0)
 906     return GFC_DEP_OVERLAP;
 907
 908   /* Positive strides.  */
 909   if (s == 1)
 910     {
 911       /* Check for elem < lower.  */
 912       if (start && gfc_dep_compare_expr (elem, start) == -1)
 913         return GFC_DEP_NODEP;
 914       /* Check for elem > upper.  */
 915       if (end && gfc_dep_compare_expr (elem, end) == 1)
 916         return GFC_DEP_NODEP;
 917
 918       if (start && end)
 919         {
 920           s = gfc_dep_compare_expr (start, end);
 921           /* Check for an empty range.  */
 922           if (s == 1)
 923             return GFC_DEP_NODEP;
 924           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
 925             return GFC_DEP_EQUAL;
 926         }
 927     }
 928   /* Negative strides.  */
 929   else if (s == -1)
 930     {
 931       /* Check for elem > upper.  */
 932       if (end && gfc_dep_compare_expr (elem, start) == 1)
 933         return GFC_DEP_NODEP;
 934       /* Check for elem < lower.  */
 935       if (start && gfc_dep_compare_expr (elem, end) == -1)
 936         return GFC_DEP_NODEP;
 937
 938       if (start && end)
 939         {
 940           s = gfc_dep_compare_expr (start, end);
 941           /* Check for an empty range.  */
 942           if (s == -1)
 943             return GFC_DEP_NODEP;
 944           if (s == 0 && gfc_dep_compare_expr (elem, start) == 0)
 945             return GFC_DEP_EQUAL;
 946         }
 947     }
 948   /* Unknown strides.  */
 949   else
 950     {
 951       if (!start || !end)
 952         return GFC_DEP_OVERLAP;
 953       s = gfc_dep_compare_expr (start, end);
 954       if (s == -2)
 955         return GFC_DEP_OVERLAP;
 956       /* Assume positive stride.  */
 957       if (s == -1)
 958         {
 959           /* Check for elem < lower.  */
 960           if (gfc_dep_compare_expr (elem, start) == -1)
 961             return GFC_DEP_NODEP;
 962           /* Check for elem > upper.  */
 963           if (gfc_dep_compare_expr (elem, end) == 1)
 964             return GFC_DEP_NODEP;
 965         }
 966       /* Assume negative stride.  */
 967       else if (s == 1)
 968         {
 969           /* Check for elem > upper.  */
 970           if (gfc_dep_compare_expr (elem, start) == 1)
 971             return GFC_DEP_NODEP;
 972           /* Check for elem < lower.  */
 973           if (gfc_dep_compare_expr (elem, end) == -1)
 974             return GFC_DEP_NODEP;
 975         }
 976       /* Equal bounds.  */
 977       else if (s == 0)
 978         {
 979           s = gfc_dep_compare_expr (elem, start);
 980           if (s == 0)
 981             return GFC_DEP_EQUAL;
 982           if (s == 1 || s == -1)
 983             return GFC_DEP_NODEP;
 984         }
 985     }
 986
 987   return GFC_DEP_OVERLAP;
 988 }
 989
 990
 991 /* Traverse expr, checking all EXPR_VARIABLE symbols for their
 992    forall_index attribute.  Return true if any variable may be
 993    being used as a FORALL index.  Its safe to pessimistically
 994    return true, and assume a dependency.  */
 995
 996 static bool
 997 contains_forall_index_p (gfc_expr * expr)
 998 {
 999   gfc_actual_arglist *arg;
1000   gfc_constructor *c;
1001   gfc_ref *ref;
1002   int i;
1003
1004   if (!expr)
1005     return false;
1006
1007   switch (expr->expr_type)
1008     {
1009     case EXPR_VARIABLE:
1010       if (expr->symtree->n.sym->forall_index)
1011         return true;
1012       break;
1013
1014     case EXPR_OP:
1015       if (contains_forall_index_p (expr->value.op.op1)
1016           || contains_forall_index_p (expr->value.op.op2))
1017         return true;
1018       break;
1019
1020     case EXPR_FUNCTION:
1021       for (arg = expr->value.function.actual; arg; arg = arg->next)
1022         if (contains_forall_index_p (arg->expr))
1023           return true;
1024       break;
1025
1026     case EXPR_CONSTANT:
1027     case EXPR_NULL:
1028     case EXPR_SUBSTRING:
1029       break;
1030
1031     case EXPR_STRUCTURE:
1032     case EXPR_ARRAY:
1033       for (c = expr->value.constructor; c; c = c->next)
1034         if (contains_forall_index_p (c->expr))
1035           return true;
1036       break;
1037
1038     default:
1039       gcc_unreachable ();
1040     }
1041
1042   for (ref = expr->ref; ref; ref = ref->next)
1043     switch (ref->type)
1044       {
1045       case REF_ARRAY:
1046         for (i = 0; i < ref->u.ar.dimen; i++)
1047           if (contains_forall_index_p (ref->u.ar.start[i])
1048               || contains_forall_index_p (ref->u.ar.end[i])
1049               || contains_forall_index_p (ref->u.ar.stride[i]))
1050             return true;
1051         break;
1052
1053       case REF_COMPONENT:
1054         break;
1055
1056       case REF_SUBSTRING:
1057         if (contains_forall_index_p (ref->u.ss.start)
1058             || contains_forall_index_p (ref->u.ss.end))
1059           return true;
1060         break;
1061
1062       default:
1063         gcc_unreachable ();
1064       }
1065
1066   return false;
1067 }
1068
1069 /* Determines overlapping for two single element array references.  */
1070
1071 static gfc_dependency
1072 gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
1073 {
1074   gfc_array_ref l_ar;
1075   gfc_array_ref r_ar;
1076   gfc_expr *l_start;
1077   gfc_expr *r_start;
1078   int i;
1079
1080   l_ar = lref->u.ar;
1081   r_ar = rref->u.ar;
1082   l_start = l_ar.start[n] ;
1083   r_start = r_ar.start[n] ;
1084   i = gfc_dep_compare_expr (r_start, l_start);
1085   if (i == 0)
1086     return GFC_DEP_EQUAL;
1087
1088   /* Treat two scalar variables as potentially equal.  This allows
1089      us to prove that a(i,:) and a(j,:) have no dependency.  See
1090      Gerald Roth, "Evaluation of Array Syntax Dependence Analysis",
1091      Proceedings of the International Conference on Parallel and
1092      Distributed Processing Techniques and Applications (PDPTA2001),
1093      Las Vegas, Nevada, June 2001.  */
1094   /* However, we need to be careful when either scalar expression
1095      contains a FORALL index, as these can potentially change value
1096      during the scalarization/traversal of this array reference.  */
1097   if (contains_forall_index_p (r_start)
1098       || contains_forall_index_p (l_start))
1099     return GFC_DEP_OVERLAP;
1100
1101   if (i != -2)
1102     return GFC_DEP_NODEP;
1103   return GFC_DEP_EQUAL;
1104 }
1105
1106
1107 /* Finds if two array references are overlapping or not.
1108    Return value
1109         1 : array references are overlapping.
1110         0 : array references are identical or not overlapping.  */
1111
1112 int
1113 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
1114 {
1115   int n;
1116   gfc_dependency fin_dep;
1117   gfc_dependency this_dep;
1118
1119
1120   fin_dep = GFC_DEP_ERROR;
1121   /* Dependencies due to pointers should already have been identified.
1122      We only need to check for overlapping array references.  */
1123
1124   while (lref && rref)
1125     {
1126       /* We're resolving from the same base symbol, so both refs should be
1127          the same type.  We traverse the reference chain intil we find ranges
1128          that are not equal.  */
1129       gcc_assert (lref->type == rref->type);
1130       switch (lref->type)
1131         {
1132         case REF_COMPONENT:
1133           /* The two ranges can't overlap if they are from different
1134              components.  */
1135           if (lref->u.c.component != rref->u.c.component)
1136             return 0;
1137           break;
1138
1139         case REF_SUBSTRING:
1140           /* Substring overlaps are handled by the string assignment code.  */
1141           return 0;
1142
1143         case REF_ARRAY:
1144           for (n=0; n < lref->u.ar.dimen; n++)
1145             {
1146               /* Assume dependency when either of array reference is vector
1147                  subscript.  */
1148               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1149                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1150                 return 1;
1151               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1152                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1153                 this_dep = gfc_check_section_vs_section (lref, rref, n);
1154               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1155                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1156                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1157               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1158                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1159                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1160               else
1161                 {
1162                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1163                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1164                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1165                 }
1166
1167               /* If any dimension doesn't overlap, we have no dependency.  */
1168               if (this_dep == GFC_DEP_NODEP)
1169                 return 0;
1170
1171               /* Overlap codes are in order of priority.  We only need to
1172                  know the worst one.*/
1173               if (this_dep > fin_dep)
1174                 fin_dep = this_dep;
1175             }
1176           /* Exactly matching and forward overlapping ranges don't cause a
1177              dependency.  */
1178           if (fin_dep < GFC_DEP_OVERLAP)
1179             return 0;
1180
1181           /* Keep checking.  We only have a dependency if
1182              subsequent references also overlap.  */
1183           break;
1184
1185         default:
1186           gcc_unreachable ();
1187         }
1188       lref = lref->next;
1189       rref = rref->next;
1190     }
1191
1192   /* If we haven't seen any array refs then something went wrong.  */
1193   gcc_assert (fin_dep != GFC_DEP_ERROR);
1194
1195   /* Assume the worst if we nest to different depths.  */
1196   if (lref || rref)
1197     return 1;
1198
1199   return fin_dep == GFC_DEP_OVERLAP;
1200 }
1201