gcc/fortran/dependency.c

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