gcc/fortran/dependency.c

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