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