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, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, 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   int i;
  76
  77   if (e1->expr_type != e2->expr_type)
  78     return -2;
  79
  80   switch (e1->expr_type)
  81     {
  82     case EXPR_CONSTANT:
  83       if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
  84         return -2;
  85
  86       i = mpz_cmp (e1->value.integer, e2->value.integer);
  87       if (i == 0)
  88         return 0;
  89       else if (i < 0)
  90         return -1;
  91       return 1;
  92
  93     case EXPR_VARIABLE:
  94       if (e1->ref || e2->ref)
  95         return -2;
  96       if (e1->symtree->n.sym == e2->symtree->n.sym)
  97         return 0;
  98       return -2;
  99
 100     default:
 101       return -2;
 102     }
 103 }
 104
 105
 106 /* Returns 1 if the two ranges are the same, 0 if they are not, and def
 107    if the results are indeterminate.  N is the dimension to compare.  */
 108
 109 int
 110 gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def)
 111 {
 112   gfc_expr *e1;
 113   gfc_expr *e2;
 114   int i;
 115
 116   /* TODO: More sophisticated range comparison.  */
 117   gcc_assert (ar1 && ar2);
 118
 119   gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]);
 120
 121   e1 = ar1->stride[n];
 122   e2 = ar2->stride[n];
 123   /* Check for mismatching strides.  A NULL stride means a stride of 1.  */
 124   if (e1 && !e2)
 125     {
 126       i = gfc_expr_is_one (e1, -1);
 127       if (i == -1)
 128         return def;
 129       else if (i == 0)
 130         return 0;
 131     }
 132   else if (e2 && !e1)
 133     {
 134       i = gfc_expr_is_one (e2, -1);
 135       if (i == -1)
 136         return def;
 137       else if (i == 0)
 138         return 0;
 139     }
 140   else if (e1 && e2)
 141     {
 142       i = gfc_dep_compare_expr (e1, e2);
 143       if (i == -2)
 144         return def;
 145       else if (i != 0)
 146         return 0;
 147     }
 148   /* The strides match.  */
 149
 150   /* Check the range start.  */
 151   e1 = ar1->start[n];
 152   e2 = ar2->start[n];
 153
 154   if (!(e1 || e2))
 155     return 1;
 156
 157   /* Use the bound of the array if no bound is specified.  */
 158   if (ar1->as && !e1)
 159     e1 = ar1->as->lower[n];
 160
 161   if (ar2->as && !e2)
 162     e2 = ar2->as->upper[n];
 163
 164   /* Check we have values for both.  */
 165   if (!(e1 && e2))
 166     return def;
 167
 168   i = gfc_dep_compare_expr (e1, e2);
 169
 170   if (i == -2)
 171     return def;
 172   else if (i == 0)
 173     return 1;
 174   return 0;
 175 }
 176
 177
 178 /* Dependency checking for direct function return by reference.
 179    Returns true if the arguments of the function depend on the
 180    destination.  This is considerably less conservative than other
 181    dependencies because many function arguments will already be
 182    copied into a temporary.  */
 183
 184 int
 185 gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall)
 186 {
 187   gfc_actual_arglist *actual;
 188   gfc_ref *ref;
 189   gfc_expr *expr;
 190   int n;
 191
 192   gcc_assert (dest->expr_type == EXPR_VARIABLE
 193           && fncall->expr_type == EXPR_FUNCTION);
 194   gcc_assert (fncall->rank > 0);
 195
 196   for (actual = fncall->value.function.actual; actual; actual = actual->next)
 197     {
 198       expr = actual->expr;
 199
 200       /* Skip args which are not present.  */
 201       if (!expr)
 202         continue;
 203
 204       /* Non-variable expressions will be allocated temporaries anyway.  */
 205       switch (expr->expr_type)
 206         {
 207         case EXPR_VARIABLE:
 208           if (expr->rank > 1)
 209             {
 210               /* This is an array section.  */
 211               for (ref = expr->ref; ref; ref = ref->next)
 212                 {
 213                   if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
 214                     break;
 215                 }
 216               gcc_assert (ref);
 217               /* AR_FULL can't contain vector subscripts.  */
 218               if (ref->u.ar.type == AR_SECTION)
 219                 {
 220                   for (n = 0; n < ref->u.ar.dimen; n++)
 221                     {
 222                       if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 223                         break;
 224                     }
 225                   /* Vector subscript array sections will be copied to a
 226                      temporary.  */
 227                   if (n != ref->u.ar.dimen)
 228                     continue;
 229                 }
 230             }
 231
 232           if (gfc_check_dependency (dest, actual->expr, NULL, 0))
 233             return 1;
 234           break;
 235
 236         case EXPR_ARRAY:
 237           if (gfc_check_dependency (dest, expr, NULL, 0))
 238             return 1;
 239           break;
 240
 241         default:
 242           break;
 243         }
 244     }
 245
 246   return 0;
 247 }
 248
 249
 250 /* Return true if the statement body redefines the condition.  Returns
 251    true if expr2 depends on expr1.  expr1 should be a single term
 252    suitable for the lhs of an assignment.  The symbols listed in VARS
 253    must be considered to have all possible values. All other scalar
 254    variables may be considered constant.  Used for forall and where
 255    statements.  Also used with functions returning arrays without a
 256    temporary.  */
 257
 258 int
 259 gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars,
 260                       int nvars)
 261 {
 262   gfc_ref *ref;
 263   int n;
 264   gfc_actual_arglist *actual;
 265
 266   gcc_assert (expr1->expr_type == EXPR_VARIABLE);
 267
 268   /* TODO: -fassume-no-pointer-aliasing */
 269   if (expr1->symtree->n.sym->attr.pointer)
 270     return 1;
 271   for (ref = expr1->ref; ref; ref = ref->next)
 272     {
 273       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 274         return 1;
 275     }
 276
 277   switch (expr2->expr_type)
 278     {
 279     case EXPR_OP:
 280       n = gfc_check_dependency (expr1, expr2->value.op.op1, vars, nvars);
 281       if (n)
 282         return n;
 283       if (expr2->value.op.op2)
 284         return gfc_check_dependency (expr1, expr2->value.op.op2, vars, nvars);
 285       return 0;
 286
 287     case EXPR_VARIABLE:
 288       if (expr2->symtree->n.sym->attr.pointer)
 289         return 1;
 290
 291       for (ref = expr2->ref; ref; ref = ref->next)
 292         {
 293           if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
 294             return 1;
 295         }
 296
 297       if (expr1->symtree->n.sym != expr2->symtree->n.sym)
 298         return 0;
 299
 300       for (ref = expr2->ref; ref; ref = ref->next)
 301         {
 302           /* Identical ranges return 0, overlapping ranges return 1.  */
 303           if (ref->type == REF_ARRAY)
 304             return 1;
 305         }
 306       return 1;
 307
 308     case EXPR_FUNCTION:
 309       /* Remember possible differences between elemental and
 310          transformational functions.  All functions inside a FORALL
 311          will be pure.  */
 312       for (actual = expr2->value.function.actual;
 313            actual; actual = actual->next)
 314         {
 315           if (!actual->expr)
 316             continue;
 317           n = gfc_check_dependency (expr1, actual->expr, vars, nvars);
 318           if (n)
 319             return n;
 320         }
 321       return 0;
 322
 323     case EXPR_CONSTANT:
 324       return 0;
 325
 326     case EXPR_ARRAY:
 327       /* Probably ok in the majority of (constant) cases.  */
 328       return 1;
 329
 330     default:
 331       return 1;
 332     }
 333 }
 334
 335
 336 /* Calculates size of the array reference using lower bound, upper bound
 337    and stride.  */
 338
 339 static void
 340 get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1)
 341 {
 342   /* nNoOfEle = (u1-l1)/s1  */
 343
 344   mpz_sub (ele, u1->value.integer, l1->value.integer);
 345
 346   if (s1 != NULL)
 347     mpz_tdiv_q (ele, ele, s1->value.integer);
 348 }
 349
 350
 351 /* Returns if the ranges ((0..Y), (X1..X2))  overlap.  */
 352
 353 static gfc_dependency
 354 get_deps (mpz_t x1, mpz_t x2, mpz_t y)
 355 {
 356   int start;
 357   int end;
 358
 359   start = mpz_cmp_ui (x1, 0);
 360   end = mpz_cmp (x2, y);
 361
 362   /* Both ranges the same.  */
 363   if (start == 0 && end == 0)
 364     return GFC_DEP_EQUAL;
 365
 366   /* Distinct ranges.  */
 367   if ((start < 0 && mpz_cmp_ui (x2, 0) < 0)
 368       || (mpz_cmp (x1, y) > 0 && end > 0))
 369     return GFC_DEP_NODEP;
 370
 371   /* Overlapping, but with corresponding elements of the second range
 372      greater than the first.  */
 373   if (start > 0 && end > 0)
 374     return GFC_DEP_FORWARD;
 375
 376   /* Overlapping in some other way.  */
 377   return GFC_DEP_OVERLAP;
 378 }
 379
 380
 381 /* Transforms a sections l and r such that
 382    (l_start:l_end:l_stride) -> (0:no_of_elements)
 383    (r_start:r_end:r_stride) -> (X1:X2)
 384    Where r_end is implicit as both sections must have the same number of
 385    elements.
 386    Returns 0 on success, 1 of the transformation failed.  */
 387 /* TODO: Should this be (0:no_of_elements-1) */
 388
 389 static int
 390 transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements,
 391                     gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride,
 392                     gfc_expr * r_start, gfc_expr * r_stride)
 393 {
 394   if (NULL == l_start || NULL == l_end || NULL == r_start)
 395     return 1;
 396
 397   /* TODO : Currently we check the dependency only when start, end and stride
 398     are constant.  We could also check for equal (variable) values, and
 399     common subexpressions, eg. x vs. x+1.  */
 400
 401   if (l_end->expr_type != EXPR_CONSTANT
 402       || l_start->expr_type != EXPR_CONSTANT
 403       || r_start->expr_type != EXPR_CONSTANT
 404       || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT))
 405       || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT)))
 406     {
 407        return 1;
 408     }
 409
 410
 411   get_no_of_elements (no_of_elements, l_end, l_start, l_stride);
 412
 413   mpz_sub (X1, r_start->value.integer, l_start->value.integer);
 414   if (l_stride != NULL)
 415     mpz_cdiv_q (X1, X1, l_stride->value.integer);
 416
 417   if (r_stride == NULL)
 418     mpz_set (X2, no_of_elements);
 419   else
 420     mpz_mul (X2, no_of_elements, r_stride->value.integer);
 421
 422   if (l_stride != NULL)
 423     mpz_cdiv_q (X2, X2, r_stride->value.integer);
 424   mpz_add (X2, X2, X1);
 425
 426   return 0;
 427 }
 428
 429
 430 /* Determines overlapping for two array sections.  */
 431
 432 static gfc_dependency
 433 gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n)
 434 {
 435   gfc_expr *l_start;
 436   gfc_expr *l_end;
 437   gfc_expr *l_stride;
 438
 439   gfc_expr *r_start;
 440   gfc_expr *r_stride;
 441
 442   gfc_array_ref l_ar;
 443   gfc_array_ref r_ar;
 444
 445   mpz_t no_of_elements;
 446   mpz_t X1, X2;
 447   gfc_dependency dep;
 448
 449   l_ar = lref->u.ar;
 450   r_ar = rref->u.ar;
 451
 452   l_start = l_ar.start[n];
 453   l_end = l_ar.end[n];
 454   l_stride = l_ar.stride[n];
 455   r_start = r_ar.start[n];
 456   r_stride = r_ar.stride[n];
 457
 458   /* if l_start is NULL take it from array specifier  */
 459   if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as))
 460     l_start = l_ar.as->lower[n];
 461
 462   /* if l_end is NULL take it from array specifier  */
 463   if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as))
 464     l_end = l_ar.as->upper[n];
 465
 466   /* if r_start is NULL take it from array specifier  */
 467   if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as))
 468     r_start = r_ar.as->lower[n];
 469
 470   mpz_init (X1);
 471   mpz_init (X2);
 472   mpz_init (no_of_elements);
 473
 474   if (transform_sections (X1, X2, no_of_elements,
 475                           l_start, l_end, l_stride,
 476                           r_start, r_stride))
 477     dep = GFC_DEP_OVERLAP;
 478   else
 479     dep =  get_deps (X1, X2, no_of_elements);
 480
 481   mpz_clear (no_of_elements);
 482   mpz_clear (X1);
 483   mpz_clear (X2);
 484   return dep;
 485 }
 486
 487
 488 /* Checks if the expr chk is inside the range left-right.
 489    Returns  GFC_DEP_NODEP if chk is outside the range,
 490    GFC_DEP_OVERLAP otherwise.
 491    Assumes left<=right.  */
 492
 493 static gfc_dependency
 494 gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right)
 495 {
 496   int l;
 497   int r;
 498   int s;
 499
 500   s = gfc_dep_compare_expr (left, right);
 501   if (s == -2)
 502     return GFC_DEP_OVERLAP;
 503
 504   l = gfc_dep_compare_expr (chk, left);
 505   r = gfc_dep_compare_expr (chk, right);
 506
 507   /* Check for indeterminate relationships.  */
 508   if (l == -2 || r == -2 || s == -2)
 509     return GFC_DEP_OVERLAP;
 510
 511   if (s == 1)
 512     {
 513       /* When left>right we want to check for right <= chk <= left.  */
 514       if (l <= 0 || r >= 0)
 515         return GFC_DEP_OVERLAP;
 516     }
 517   else
 518     {
 519       /* Otherwise check for left <= chk <= right.  */
 520       if (l >= 0 || r <= 0)
 521         return GFC_DEP_OVERLAP;
 522     }
 523
 524   return GFC_DEP_NODEP;
 525 }
 526
 527
 528 /* Determines overlapping for a single element and a section.  */
 529
 530 static gfc_dependency
 531 gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n)
 532 {
 533   gfc_array_ref l_ar;
 534   gfc_array_ref r_ar;
 535   gfc_expr *l_start;
 536   gfc_expr *r_start;
 537   gfc_expr *r_end;
 538
 539   l_ar = lref->u.ar;
 540   r_ar = rref->u.ar;
 541   l_start = l_ar.start[n] ;
 542   r_start = r_ar.start[n] ;
 543   r_end = r_ar.end[n] ;
 544   if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as))
 545     r_start = r_ar.as->lower[n];
 546   if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as))
 547     r_end = r_ar.as->upper[n];
 548   if (NULL == r_start || NULL == r_end || l_start == NULL)
 549     return GFC_DEP_OVERLAP;
 550
 551   return gfc_is_inside_range (l_start, r_end, r_start);
 552 }
 553
 554
 555 /* Determines overlapping for two single element array references.  */
 556
 557 static gfc_dependency
 558 gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n)
 559 {
 560   gfc_array_ref l_ar;
 561   gfc_array_ref r_ar;
 562   gfc_expr *l_start;
 563   gfc_expr *r_start;
 564   gfc_dependency nIsDep;
 565
 566   if (lref->type == REF_ARRAY && rref->type == REF_ARRAY)
 567     {
 568       l_ar = lref->u.ar;
 569       r_ar = rref->u.ar;
 570       l_start = l_ar.start[n] ;
 571       r_start = r_ar.start[n] ;
 572       if (gfc_dep_compare_expr (r_start, l_start) == 0)
 573         nIsDep = GFC_DEP_EQUAL;
 574       else
 575         nIsDep = GFC_DEP_NODEP;
 576   }
 577   else
 578     nIsDep = GFC_DEP_NODEP;
 579
 580   return nIsDep;
 581 }
 582
 583
 584 /* Finds if two array references are overlapping or not.
 585    Return value
 586         1 : array references are overlapping.
 587         0 : array references are not overlapping.  */
 588
 589 int
 590 gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref)
 591 {
 592   int n;
 593   gfc_dependency fin_dep;
 594   gfc_dependency this_dep;
 595
 596
 597   fin_dep = GFC_DEP_ERROR;
 598   /* Dependencies due to pointers should already have been identified.
 599      We only need to check for overlapping array references.  */
 600
 601   while (lref && rref)
 602     {
 603       /* We're resolving from the same base symbol, so both refs should be
 604          the same type.  We traverse the reference chain intil we find ranges
 605          that are not equal.  */
 606       gcc_assert (lref->type == rref->type);
 607       switch (lref->type)
 608         {
 609         case REF_COMPONENT:
 610           /* The two ranges can't overlap if they are from different
 611              components.  */
 612           if (lref->u.c.component != rref->u.c.component)
 613             return 0;
 614           break;
 615
 616         case REF_SUBSTRING:
 617           /* Substring overlaps are handled by the string assignment code.  */
 618           return 0;
 619
 620         case REF_ARRAY:
 621
 622           for (n=0; n < lref->u.ar.dimen; n++)
 623             {
 624               /* Assume dependency when either of array reference is vector
 625                  subscript.  */
 626               if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
 627                   || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
 628                 return 1;
 629               if (lref->u.ar.dimen_type[n] == DIMEN_RANGE
 630                   && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 631                 this_dep = gfc_check_section_vs_section (lref, rref, n);
 632               else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 633                        && rref->u.ar.dimen_type[n] == DIMEN_RANGE)
 634                 this_dep = gfc_check_element_vs_section (lref, rref, n);
 635               else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 636                        && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
 637                 this_dep = gfc_check_element_vs_section (rref, lref, n);
 638               else
 639                 {
 640                   gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
 641                           && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
 642                   this_dep = gfc_check_element_vs_element (rref, lref, n);
 643                 }
 644
 645               /* If any dimension doesn't overlap, we have no dependency.  */
 646               if (this_dep == GFC_DEP_NODEP)
 647                 return 0;
 648
 649               /* Overlap codes are in order of priority.  We only need to
 650                  know the worst one.*/
 651               if (this_dep > fin_dep)
 652                 fin_dep = this_dep;
 653             }
 654           /* Exactly matching and forward overlapping ranges don't cause a
 655              dependency.  */
 656           if (fin_dep < GFC_DEP_OVERLAP)
 657             return 0;
 658
 659           /* Keep checking.  We only have a dependency if
 660              subsequent references also overlap.  */
 661           break;
 662
 663         default:
 664           gcc_unreachable ();
 665         }
 666       lref = lref->next;
 667       rref = rref->next;
 668     }
 669
 670   /* If we haven't seen any array refs then something went wrong.  */
 671   gcc_assert (fin_dep != GFC_DEP_ERROR);
 672
 673   if (fin_dep < GFC_DEP_OVERLAP)
 674     return 0;
 675   else
 676     return 1;
 677 }
 678