gcc/fortran/dependency.c

   1 /* Dependency analysis
   2    Copyright (C) 2000, 2001, 2002, 2005 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 /* Calculates size of the array reference using lower bound, upper bound
 706    and stride.  */
 707
 708 static void
 709 get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
 710 {
 711   /* nNoOfEle = (u1-l1)/s1  */
 712
 713   mpz_sub (ele, u1->value.integer, l1->value.integer);
 714
 715   if (s1 != NULL)
 716     mpz_tdiv_q (ele, ele, s1->value.integer);
 717 }
 718
 719
 720 /* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
 721
 722 static gfc_dependency
 723 get_deps (mpz_t x1, mpz_t x2, mpz_t y)
 724 {
 725   int start;
 726   int end;
 727
 728   start = mpz_cmp_ui (x1, 0);
 729   end = mpz_cmp (x2, y);
 730
 731   /* Both ranges the same.  */
 732   if (start == 0 && end == 0)
 733     return GFC_DEP_EQUAL;
 734
 735   /* Distinct ranges.  */
 736   if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
 737       || (mpz_cmp (x1, y) > 0 && end > 0))
 738     return GFC_DEP_NODEP;
 739
 740   /* Overlapping, but with corresponding elements of the second range
 741      greater than the first.  */
 742   if (start > 0 && end > 0)
 743     return GFC_DEP_FORWARD;
 744
 745   /* Overlapping in some other way.  */
 746   return GFC_DEP_OVERLAP;
 747 }
 748
 749
 750 /* Perform the same linear transformation on sections l and r such that
 751    (l_start:l_end:l_stride) -> (0:no_of_elements)
 752    (r_start:r_end:r_stride) -> (X1:X2)
 753    Where r_end is implicit as both sections must have the same number of
 754    elements.
 755    Returns 0 on success, 1 of the transformation failed.  */
 756 /* TODO: Should this be (0:no_of_elements-1) */
 757
 758 static int
 759 transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
 760                     gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
 761                     gfc_expr * r_start, gfc_expr * r_stride)
 762 {
 763   if (NULL == l_start || NULL == l_end || NULL == r_start)
 764     return 1;
 765
 766   /* TODO : Currently we check the dependency only when start, end and stride
 767     are constant.  We could also check for equal (variable) values, and
 768     common subexpressions, eg. x vs. x+1.  */
 769
 770   if (l_end->expr_type != EXPR_CONSTANT
 771       || l_start->expr_type != EXPR_CONSTANT
 772       || r_start->expr_type != EXPR_CONSTANT
 773       || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
 774       || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
 775     {
 776        return 1;
 777     }
 778
 779
 780   get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
 781
 782   mpz_sub (X1, r_start->value.integer, l_start->value.integer);
 783   if (l_stride != NULL)
 784     mpz_cdiv_q (X1, X1, l_stride->value.integer);
 785
 786   if (r_stride == NULL)
 787     mpz_set (X2, no_of_elements);
 788   else
 789     mpz_mul (X2, no_of_elements, r_stride->value.integer);
 790
 791   if (l_stride != NULL)
 792     mpz_cdiv_q (X2, X2, l_stride->value.integer);
 793   mpz_add (X2, X2, X1);
 794
 795   return 0;
 796 }
 797
 798
 799 /* Determines overlapping for two array sections.  */
 800
 801 static gfc_dependency
 802 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 803 {
 804   gfc_expr *l_start;
 805   gfc_expr *l_end;
 806   gfc_expr *l_stride;
 807
 808   gfc_expr *r_start;
 809   gfc_expr *r_stride;
 810
 811   gfc_array_ref l_ar;
 812   gfc_array_ref r_ar;
 813
 814   mpz_t no_of_elements;
 815   mpz_t X1, X2;
 816   gfc_dependency dep;
 817
 818   l_ar = lref->u.ar;
 819   r_ar = rref->u.ar;
 820
 821   /* If they are the same range, return without more ado.  */
 822   if (gfc_is_same_range (&l_ar, &r_ar, n, 0))
 823     return GFC_DEP_EQUAL;
 824
 825   l_start = l_ar.start[n];
 826   l_end = l_ar.end[n];
 827   l_stride = l_ar.stride[n];
 828   r_start = r_ar.start[n];
 829   r_stride = r_ar.stride[n];
 830
 831   /* if l_start is NULL take it from array specifier  */
 832   if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
 833     l_start = l_ar.as->lower[n];
 834
 835   /* if l_end is NULL take it from array specifier  */
 836   if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
 837     l_end = l_ar.as->upper[n];
 838
 839   /* if r_start is NULL take it from array specifier  */
 840   if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
 841     r_start = r_ar.as->lower[n];
 842
 843   mpz_init (X1);
 844   mpz_init (X2);
 845   mpz_init (no_of_elements);
 846
 847   if (transform_sections (X1, X2, no_of_elements,
 848                           l_start, l_end, l_stride,
 849                           r_start, r_stride))
 850     dep = GFC_DEP_OVERLAP;
 851   else
 852     dep =  get_deps (X1, X2, no_of_elements);
 853
 854   mpz_clear (no_of_elements);
 855   mpz_clear (X1);
 856   mpz_clear (X2);
 857   return dep;
 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)
1090       || contains_forall_index_p (l_start))
1091     return GFC_DEP_OVERLAP;
1092
1093   if (i != -2)
1094     return GFC_DEP_NODEP;
1095   return GFC_DEP_EQUAL;
1096 }
1097
1098
1099 /* Finds if two array references are overlapping or not.
1100    Return value
1101         1 : array references are overlapping.
1102         0 : array references are identical or not overlapping.  */
1103
1104 int
1105 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
1106 {
1107   int n;
1108   gfc_dependency fin_dep;
1109   gfc_dependency this_dep;
1110
1111
1112   fin_dep = GFC_DEP_ERROR;
1113   /* Dependencies due to pointers should already have been identified.
1114      We only need to check for overlapping array references.  */
1115
1116   while (lref && rref)
1117     {
1118       /* We're resolving from the same base symbol, so both refs should be
1119          the same type.  We traverse the reference chain intil we find ranges
1120          that are not equal.  */
1121       gcc_assert (lref->type == rref->type);
1122       switch (lref->type)
1123         {
1124         case REF_COMPONENT:
1125           /* The two ranges can't overlap if they are from different
1126              components.  */
1127           if (lref->u.c.component != rref->u.c.component)
1128             return 0;
1129           break;
1130
1131         case REF_SUBSTRING:
1132           /* Substring overlaps are handled by the string assignment code.  */
1133           return 0;
1134
1135         case REF_ARRAY:
1136           for (n=0; n < lref->u.ar.dimen; n++)
1137             {
1138               /* Assume dependency when either of array reference is vector
1139                  subscript.  */
1140               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
1141                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
1142                 return 1;
1143               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
1144                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1145                 this_dep = gfc_check_section_vs_section (lref, rref, n);
1146               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1147                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
1148                 this_dep = gfc_check_element_vs_section (lref, rref, n);
1149               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1150                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
1151                 this_dep = gfc_check_element_vs_section (rref, lref, n);
1152               else
1153                 {
1154                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
1155                               && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
1156                   this_dep = gfc_check_element_vs_element (rref, lref, n);
1157                 }
1158
1159               /* If any dimension doesn't overlap, we have no dependency.  */
1160               if (this_dep == GFC_DEP_NODEP)
1161                 return 0;
1162
1163               /* Overlap codes are in order of priority.  We only need to
1164                  know the worst one.*/
1165               if (this_dep > fin_dep)
1166                 fin_dep = this_dep;
1167             }
1168           /* Exactly matching and forward overlapping ranges don't cause a
1169              dependency.  */
1170           if (fin_dep < GFC_DEP_OVERLAP)
1171             return 0;
1172
1173           /* Keep checking.  We only have a dependency if
1174              subsequent references also overlap.  */
1175           break;
1176
1177         default:
1178           gcc_unreachable ();
1179         }
1180       lref = lref->next;
1181       rref = rref->next;
1182     }
1183
1184   /* If we haven't seen any array refs then something went wrong.  */
1185   gcc_assert (fin_dep != GFC_DEP_ERROR);
1186
1187   /* Assume the worst if we nest to different depths.  */
1188   if (lref || rref)
1189     return 1;
1190
1191   return fin_dep == GFC_DEP_OVERLAP;
1192 }
1193