1 /* Dependency analysis 2 Copyright (C) 2000-2019 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 3, 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 COPYING3. If not see 19 <http://www.gnu.org/licenses/>. */ 20 21 /* dependency.c -- Expression dependency analysis code. */ 22 /* There's probably quite a bit of duplication in this file. We currently 23 have different dependency checking functions for different types 24 if dependencies. Ideally these would probably be merged. */ 25 26 #include "config.h" 27 #include "system.h" 28 #include "coretypes.h" 29 #include "gfortran.h" 30 #include "dependency.h" 31 #include "constructor.h" 32 #include "arith.h" 33 34 /* static declarations */ 35 /* Enums */ 36 enum range {LHS, RHS, MID}; 37 38 /* Dependency types. These must be in reverse order of priority. */ 39 enum gfc_dependency 40 { 41 GFC_DEP_ERROR, 42 GFC_DEP_EQUAL, /* Identical Ranges. */ 43 GFC_DEP_FORWARD, /* e.g., a(1:3) = a(2:4). */ 44 GFC_DEP_BACKWARD, /* e.g. a(2:4) = a(1:3). */ 45 GFC_DEP_OVERLAP, /* May overlap in some other way. */ 46 GFC_DEP_NODEP /* Distinct ranges. */ 47 }; 48 49 /* Macros */ 50 #define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) 51 52 /* Forward declarations */ 53 54 static gfc_dependency check_section_vs_section (gfc_array_ref *, 55 gfc_array_ref *, int); 56 57 /* Returns 1 if the expr is an integer constant value 1, 0 if it is not or 58 def if the value could not be determined. */ 59 60 int 61 gfc_expr_is_one (gfc_expr *expr, int def) 62 { 63 gcc_assert (expr != NULL); 64 65 if (expr->expr_type != EXPR_CONSTANT) 66 return def; 67 68 if (expr->ts.type != BT_INTEGER) 69 return def; 70 71 return mpz_cmp_si (expr->value.integer, 1) == 0; 72 } 73 74 /* Check if two array references are known to be identical. Calls 75 gfc_dep_compare_expr if necessary for comparing array indices. */ 76 77 static bool 78 identical_array_ref (gfc_array_ref *a1, gfc_array_ref *a2) 79 { 80 int i; 81 82 if (a1->type == AR_FULL && a2->type == AR_FULL) 83 return true; 84 85 if (a1->type == AR_SECTION && a2->type == AR_SECTION) 86 { 87 gcc_assert (a1->dimen == a2->dimen); 88 89 for ( i = 0; i < a1->dimen; i++) 90 { 91 /* TODO: Currently, we punt on an integer array as an index. */ 92 if (a1->dimen_type[i] != DIMEN_RANGE 93 || a2->dimen_type[i] != DIMEN_RANGE) 94 return false; 95 96 if (check_section_vs_section (a1, a2, i) != GFC_DEP_EQUAL) 97 return false; 98 } 99 return true; 100 } 101 102 if (a1->type == AR_ELEMENT && a2->type == AR_ELEMENT) 103 { 104 if (a1->dimen != a2->dimen) 105 gfc_internal_error ("identical_array_ref(): inconsistent dimensions"); 106 107 for (i = 0; i < a1->dimen; i++) 108 { 109 if (gfc_dep_compare_expr (a1->start[i], a2->start[i]) != 0) 110 return false; 111 } 112 return true; 113 } 114 return false; 115 } 116 117 118 119 /* Return true for identical variables, checking for references if 120 necessary. Calls identical_array_ref for checking array sections. */ 121 122 static bool 123 are_identical_variables (gfc_expr *e1, gfc_expr *e2) 124 { 125 gfc_ref *r1, *r2; 126 127 if (e1->symtree->n.sym->attr.dummy && e2->symtree->n.sym->attr.dummy) 128 { 129 /* Dummy arguments: Only check for equal names. */ 130 if (e1->symtree->n.sym->name != e2->symtree->n.sym->name) 131 return false; 132 } 133 else 134 { 135 /* Check for equal symbols. */ 136 if (e1->symtree->n.sym != e2->symtree->n.sym) 137 return false; 138 } 139 140 /* Volatile variables should never compare equal to themselves. */ 141 142 if (e1->symtree->n.sym->attr.volatile_) 143 return false; 144 145 r1 = e1->ref; 146 r2 = e2->ref; 147 148 while (r1 != NULL || r2 != NULL) 149 { 150 151 /* Assume the variables are not equal if one has a reference and the 152 other doesn't. 153 TODO: Handle full references like comparing a(:) to a. 154 */ 155 156 if (r1 == NULL || r2 == NULL) 157 return false; 158 159 if (r1->type != r2->type) 160 return false; 161 162 switch (r1->type) 163 { 164 165 case REF_ARRAY: 166 if (!identical_array_ref (&r1->u.ar, &r2->u.ar)) 167 return false; 168 169 break; 170 171 case REF_COMPONENT: 172 if (r1->u.c.component != r2->u.c.component) 173 return false; 174 break; 175 176 case REF_SUBSTRING: 177 if (gfc_dep_compare_expr (r1->u.ss.start, r2->u.ss.start) != 0) 178 return false; 179 180 /* If both are NULL, the end length compares equal, because we 181 are looking at the same variable. This can only happen for 182 assumed- or deferred-length character arguments. */ 183 184 if (r1->u.ss.end == NULL && r2->u.ss.end == NULL) 185 break; 186 187 if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0) 188 return false; 189 190 break; 191 192 case REF_INQUIRY: 193 if (r1->u.i != r2->u.i) 194 return false; 195 break; 196 197 default: 198 gfc_internal_error ("are_identical_variables: Bad type"); 199 } 200 r1 = r1->next; 201 r2 = r2->next; 202 } 203 return true; 204 } 205 206 /* Compare two functions for equality. Returns 0 if e1==e2, -2 otherwise. If 207 impure_ok is false, only return 0 for pure functions. */ 208 209 int 210 gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok) 211 { 212 213 gfc_actual_arglist *args1; 214 gfc_actual_arglist *args2; 215 216 if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION) 217 return -2; 218 219 if ((e1->value.function.esym && e2->value.function.esym 220 && e1->value.function.esym == e2->value.function.esym 221 && (e1->value.function.esym->result->attr.pure || impure_ok)) 222 || (e1->value.function.isym && e2->value.function.isym 223 && e1->value.function.isym == e2->value.function.isym 224 && (e1->value.function.isym->pure || impure_ok))) 225 { 226 args1 = e1->value.function.actual; 227 args2 = e2->value.function.actual; 228 229 /* Compare the argument lists for equality. */ 230 while (args1 && args2) 231 { 232 /* Bitwise xor, since C has no non-bitwise xor operator. */ 233 if ((args1->expr == NULL) ^ (args2->expr == NULL)) 234 return -2; 235 236 if (args1->expr != NULL && args2->expr != NULL) 237 { 238 gfc_expr *e1, *e2; 239 e1 = args1->expr; 240 e2 = args2->expr; 241 242 if (gfc_dep_compare_expr (e1, e2) != 0) 243 return -2; 244 245 /* Special case: String arguments which compare equal can have 246 different lengths, which makes them different in calls to 247 procedures. */ 248 249 if (e1->expr_type == EXPR_CONSTANT 250 && e1->ts.type == BT_CHARACTER 251 && e2->expr_type == EXPR_CONSTANT 252 && e2->ts.type == BT_CHARACTER 253 && e1->value.character.length != e2->value.character.length) 254 return -2; 255 } 256 257 args1 = args1->next; 258 args2 = args2->next; 259 } 260 return (args1 || args2) ? -2 : 0; 261 } 262 else 263 return -2; 264 } 265 266 /* Helper function to look through parens, unary plus and widening 267 integer conversions. */ 268 269 gfc_expr * 270 gfc_discard_nops (gfc_expr *e) 271 { 272 gfc_actual_arglist *arglist; 273 274 if (e == NULL) 275 return NULL; 276 277 while (true) 278 { 279 if (e->expr_type == EXPR_OP 280 && (e->value.op.op == INTRINSIC_UPLUS 281 || e->value.op.op == INTRINSIC_PARENTHESES)) 282 { 283 e = e->value.op.op1; 284 continue; 285 } 286 287 if (e->expr_type == EXPR_FUNCTION && e->value.function.isym 288 && e->value.function.isym->id == GFC_ISYM_CONVERSION 289 && e->ts.type == BT_INTEGER) 290 { 291 arglist = e->value.function.actual; 292 if (arglist->expr->ts.type == BT_INTEGER 293 && e->ts.kind > arglist->expr->ts.kind) 294 { 295 e = arglist->expr; 296 continue; 297 } 298 } 299 break; 300 } 301 302 return e; 303 } 304 305 306 /* Compare two expressions. Return values: 307 * +1 if e1 > e2 308 * 0 if e1 == e2 309 * -1 if e1 < e2 310 * -2 if the relationship could not be determined 311 * -3 if e1 /= e2, but we cannot tell which one is larger. 312 REAL and COMPLEX constants are only compared for equality 313 or inequality; if they are unequal, -2 is returned in all cases. */ 314 315 int 316 gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) 317 { 318 int i; 319 320 if (e1 == NULL && e2 == NULL) 321 return 0; 322 323 e1 = gfc_discard_nops (e1); 324 e2 = gfc_discard_nops (e2); 325 326 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) 327 { 328 /* Compare X+C vs. X, for INTEGER only. */ 329 if (e1->value.op.op2->expr_type == EXPR_CONSTANT 330 && e1->value.op.op2->ts.type == BT_INTEGER 331 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) 332 return mpz_sgn (e1->value.op.op2->value.integer); 333 334 /* Compare P+Q vs. R+S. */ 335 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) 336 { 337 int l, r; 338 339 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); 340 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); 341 if (l == 0 && r == 0) 342 return 0; 343 if (l == 0 && r > -2) 344 return r; 345 if (l > -2 && r == 0) 346 return l; 347 if (l == 1 && r == 1) 348 return 1; 349 if (l == -1 && r == -1) 350 return -1; 351 352 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2); 353 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1); 354 if (l == 0 && r == 0) 355 return 0; 356 if (l == 0 && r > -2) 357 return r; 358 if (l > -2 && r == 0) 359 return l; 360 if (l == 1 && r == 1) 361 return 1; 362 if (l == -1 && r == -1) 363 return -1; 364 } 365 } 366 367 /* Compare X vs. X+C, for INTEGER only. */ 368 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) 369 { 370 if (e2->value.op.op2->expr_type == EXPR_CONSTANT 371 && e2->value.op.op2->ts.type == BT_INTEGER 372 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) 373 return -mpz_sgn (e2->value.op.op2->value.integer); 374 } 375 376 /* Compare X-C vs. X, for INTEGER only. */ 377 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) 378 { 379 if (e1->value.op.op2->expr_type == EXPR_CONSTANT 380 && e1->value.op.op2->ts.type == BT_INTEGER 381 && gfc_dep_compare_expr (e1->value.op.op1, e2) == 0) 382 return -mpz_sgn (e1->value.op.op2->value.integer); 383 384 /* Compare P-Q vs. R-S. */ 385 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 386 { 387 int l, r; 388 389 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); 390 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); 391 if (l == 0 && r == 0) 392 return 0; 393 if (l > -2 && r == 0) 394 return l; 395 if (l == 0 && r > -2) 396 return -r; 397 if (l == 1 && r == -1) 398 return 1; 399 if (l == -1 && r == 1) 400 return -1; 401 } 402 } 403 404 /* Compare A // B vs. C // D. */ 405 406 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_CONCAT 407 && e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_CONCAT) 408 { 409 int l, r; 410 411 l = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); 412 r = gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2); 413 414 if (l != 0) 415 return l; 416 417 /* Left expressions of // compare equal, but 418 watch out for 'A ' // x vs. 'A' // x. */ 419 gfc_expr *e1_left = e1->value.op.op1; 420 gfc_expr *e2_left = e2->value.op.op1; 421 422 if (e1_left->expr_type == EXPR_CONSTANT 423 && e2_left->expr_type == EXPR_CONSTANT 424 && e1_left->value.character.length 425 != e2_left->value.character.length) 426 return -2; 427 else 428 return r; 429 } 430 431 /* Compare X vs. X-C, for INTEGER only. */ 432 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 433 { 434 if (e2->value.op.op2->expr_type == EXPR_CONSTANT 435 && e2->value.op.op2->ts.type == BT_INTEGER 436 && gfc_dep_compare_expr (e1, e2->value.op.op1) == 0) 437 return mpz_sgn (e2->value.op.op2->value.integer); 438 } 439 440 if (e1->expr_type != e2->expr_type) 441 return -3; 442 443 switch (e1->expr_type) 444 { 445 case EXPR_CONSTANT: 446 /* Compare strings for equality. */ 447 if (e1->ts.type == BT_CHARACTER && e2->ts.type == BT_CHARACTER) 448 return gfc_compare_string (e1, e2); 449 450 /* Compare REAL and COMPLEX constants. Because of the 451 traps and pitfalls associated with comparing 452 a + 1.0 with a + 0.5, check for equality only. */ 453 if (e2->expr_type == EXPR_CONSTANT) 454 { 455 if (e1->ts.type == BT_REAL && e2->ts.type == BT_REAL) 456 { 457 if (mpfr_cmp (e1->value.real, e2->value.real) == 0) 458 return 0; 459 else 460 return -2; 461 } 462 else if (e1->ts.type == BT_COMPLEX && e2->ts.type == BT_COMPLEX) 463 { 464 if (mpc_cmp (e1->value.complex, e2->value.complex) == 0) 465 return 0; 466 else 467 return -2; 468 } 469 } 470 471 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) 472 return -2; 473 474 /* For INTEGER, all cases where e2 is not constant should have 475 been filtered out above. */ 476 gcc_assert (e2->expr_type == EXPR_CONSTANT); 477 478 i = mpz_cmp (e1->value.integer, e2->value.integer); 479 if (i == 0) 480 return 0; 481 else if (i < 0) 482 return -1; 483 return 1; 484 485 case EXPR_VARIABLE: 486 if (are_identical_variables (e1, e2)) 487 return 0; 488 else 489 return -3; 490 491 case EXPR_OP: 492 /* Intrinsic operators are the same if their operands are the same. */ 493 if (e1->value.op.op != e2->value.op.op) 494 return -2; 495 if (e1->value.op.op2 == 0) 496 { 497 i = gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1); 498 return i == 0 ? 0 : -2; 499 } 500 if (gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op1) == 0 501 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op2) == 0) 502 return 0; 503 else if (e1->value.op.op == INTRINSIC_TIMES 504 && gfc_dep_compare_expr (e1->value.op.op1, e2->value.op.op2) == 0 505 && gfc_dep_compare_expr (e1->value.op.op2, e2->value.op.op1) == 0) 506 /* Commutativity of multiplication; addition is handled above. */ 507 return 0; 508 509 return -2; 510 511 case EXPR_FUNCTION: 512 return gfc_dep_compare_functions (e1, e2, false); 513 514 default: 515 return -2; 516 } 517 } 518 519 520 /* Return the difference between two expressions. Integer expressions of 521 the form 522 523 X + constant, X - constant and constant + X 524 525 are handled. Return true on success, false on failure. result is assumed 526 to be uninitialized on entry, and will be initialized on success. 527 */ 528 529 bool 530 gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) 531 { 532 gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2; 533 534 if (e1 == NULL || e2 == NULL) 535 return false; 536 537 if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) 538 return false; 539 540 e1 = gfc_discard_nops (e1); 541 e2 = gfc_discard_nops (e2); 542 543 /* Inizialize tentatively, clear if we don't return anything. */ 544 mpz_init (*result); 545 546 /* Case 1: c1 - c2 = c1 - c2, trivially. */ 547 548 if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT) 549 { 550 mpz_sub (*result, e1->value.integer, e2->value.integer); 551 return true; 552 } 553 554 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) 555 { 556 e1_op1 = gfc_discard_nops (e1->value.op.op1); 557 e1_op2 = gfc_discard_nops (e1->value.op.op2); 558 559 /* Case 2: (X + c1) - X = c1. */ 560 if (e1_op2->expr_type == EXPR_CONSTANT 561 && gfc_dep_compare_expr (e1_op1, e2) == 0) 562 { 563 mpz_set (*result, e1_op2->value.integer); 564 return true; 565 } 566 567 /* Case 3: (c1 + X) - X = c1. */ 568 if (e1_op1->expr_type == EXPR_CONSTANT 569 && gfc_dep_compare_expr (e1_op2, e2) == 0) 570 { 571 mpz_set (*result, e1_op1->value.integer); 572 return true; 573 } 574 575 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) 576 { 577 e2_op1 = gfc_discard_nops (e2->value.op.op1); 578 e2_op2 = gfc_discard_nops (e2->value.op.op2); 579 580 if (e1_op2->expr_type == EXPR_CONSTANT) 581 { 582 /* Case 4: X + c1 - (X + c2) = c1 - c2. */ 583 if (e2_op2->expr_type == EXPR_CONSTANT 584 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) 585 { 586 mpz_sub (*result, e1_op2->value.integer, 587 e2_op2->value.integer); 588 return true; 589 } 590 /* Case 5: X + c1 - (c2 + X) = c1 - c2. */ 591 if (e2_op1->expr_type == EXPR_CONSTANT 592 && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) 593 { 594 mpz_sub (*result, e1_op2->value.integer, 595 e2_op1->value.integer); 596 return true; 597 } 598 } 599 else if (e1_op1->expr_type == EXPR_CONSTANT) 600 { 601 /* Case 6: c1 + X - (X + c2) = c1 - c2. */ 602 if (e2_op2->expr_type == EXPR_CONSTANT 603 && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) 604 { 605 mpz_sub (*result, e1_op1->value.integer, 606 e2_op2->value.integer); 607 return true; 608 } 609 /* Case 7: c1 + X - (c2 + X) = c1 - c2. */ 610 if (e2_op1->expr_type == EXPR_CONSTANT 611 && gfc_dep_compare_expr (e1_op2, e2_op2) == 0) 612 { 613 mpz_sub (*result, e1_op1->value.integer, 614 e2_op1->value.integer); 615 return true; 616 } 617 } 618 } 619 620 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 621 { 622 e2_op1 = gfc_discard_nops (e2->value.op.op1); 623 e2_op2 = gfc_discard_nops (e2->value.op.op2); 624 625 if (e1_op2->expr_type == EXPR_CONSTANT) 626 { 627 /* Case 8: X + c1 - (X - c2) = c1 + c2. */ 628 if (e2_op2->expr_type == EXPR_CONSTANT 629 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) 630 { 631 mpz_add (*result, e1_op2->value.integer, 632 e2_op2->value.integer); 633 return true; 634 } 635 } 636 if (e1_op1->expr_type == EXPR_CONSTANT) 637 { 638 /* Case 9: c1 + X - (X - c2) = c1 + c2. */ 639 if (e2_op2->expr_type == EXPR_CONSTANT 640 && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) 641 { 642 mpz_add (*result, e1_op1->value.integer, 643 e2_op2->value.integer); 644 return true; 645 } 646 } 647 } 648 } 649 650 if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) 651 { 652 e1_op1 = gfc_discard_nops (e1->value.op.op1); 653 e1_op2 = gfc_discard_nops (e1->value.op.op2); 654 655 if (e1_op2->expr_type == EXPR_CONSTANT) 656 { 657 /* Case 10: (X - c1) - X = -c1 */ 658 659 if (gfc_dep_compare_expr (e1_op1, e2) == 0) 660 { 661 mpz_neg (*result, e1_op2->value.integer); 662 return true; 663 } 664 665 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) 666 { 667 e2_op1 = gfc_discard_nops (e2->value.op.op1); 668 e2_op2 = gfc_discard_nops (e2->value.op.op2); 669 670 /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */ 671 if (e2_op2->expr_type == EXPR_CONSTANT 672 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) 673 { 674 mpz_add (*result, e1_op2->value.integer, 675 e2_op2->value.integer); 676 mpz_neg (*result, *result); 677 return true; 678 } 679 680 /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */ 681 if (e2_op1->expr_type == EXPR_CONSTANT 682 && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) 683 { 684 mpz_add (*result, e1_op2->value.integer, 685 e2_op1->value.integer); 686 mpz_neg (*result, *result); 687 return true; 688 } 689 } 690 691 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 692 { 693 e2_op1 = gfc_discard_nops (e2->value.op.op1); 694 e2_op2 = gfc_discard_nops (e2->value.op.op2); 695 696 /* Case 13: (X - c1) - (X - c2) = c2 - c1. */ 697 if (e2_op2->expr_type == EXPR_CONSTANT 698 && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) 699 { 700 mpz_sub (*result, e2_op2->value.integer, 701 e1_op2->value.integer); 702 return true; 703 } 704 } 705 } 706 if (e1_op1->expr_type == EXPR_CONSTANT) 707 { 708 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 709 { 710 e2_op1 = gfc_discard_nops (e2->value.op.op1); 711 e2_op2 = gfc_discard_nops (e2->value.op.op2); 712 713 /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ 714 if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) 715 { 716 mpz_sub (*result, e1_op1->value.integer, 717 e2_op1->value.integer); 718 return true; 719 } 720 } 721 722 } 723 } 724 725 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) 726 { 727 e2_op1 = gfc_discard_nops (e2->value.op.op1); 728 e2_op2 = gfc_discard_nops (e2->value.op.op2); 729 730 /* Case 15: X - (X + c2) = -c2. */ 731 if (e2_op2->expr_type == EXPR_CONSTANT 732 && gfc_dep_compare_expr (e1, e2_op1) == 0) 733 { 734 mpz_neg (*result, e2_op2->value.integer); 735 return true; 736 } 737 /* Case 16: X - (c2 + X) = -c2. */ 738 if (e2_op1->expr_type == EXPR_CONSTANT 739 && gfc_dep_compare_expr (e1, e2_op2) == 0) 740 { 741 mpz_neg (*result, e2_op1->value.integer); 742 return true; 743 } 744 } 745 746 if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) 747 { 748 e2_op1 = gfc_discard_nops (e2->value.op.op1); 749 e2_op2 = gfc_discard_nops (e2->value.op.op2); 750 751 /* Case 17: X - (X - c2) = c2. */ 752 if (e2_op2->expr_type == EXPR_CONSTANT 753 && gfc_dep_compare_expr (e1, e2_op1) == 0) 754 { 755 mpz_set (*result, e2_op2->value.integer); 756 return true; 757 } 758 } 759 760 if (gfc_dep_compare_expr (e1, e2) == 0) 761 { 762 /* Case 18: X - X = 0. */ 763 mpz_set_si (*result, 0); 764 return true; 765 } 766 767 mpz_clear (*result); 768 return false; 769 } 770 771 /* Returns 1 if the two ranges are the same and 0 if they are not (or if the 772 results are indeterminate). 'n' is the dimension to compare. */ 773 774 static int 775 is_same_range (gfc_array_ref *ar1, gfc_array_ref *ar2, int n) 776 { 777 gfc_expr *e1; 778 gfc_expr *e2; 779 int i; 780 781 /* TODO: More sophisticated range comparison. */ 782 gcc_assert (ar1 && ar2); 783 784 gcc_assert (ar1->dimen_type[n] == ar2->dimen_type[n]); 785 786 e1 = ar1->stride[n]; 787 e2 = ar2->stride[n]; 788 /* Check for mismatching strides. A NULL stride means a stride of 1. */ 789 if (e1 && !e2) 790 { 791 i = gfc_expr_is_one (e1, -1); 792 if (i == -1 || i == 0) 793 return 0; 794 } 795 else if (e2 && !e1) 796 { 797 i = gfc_expr_is_one (e2, -1); 798 if (i == -1 || i == 0) 799 return 0; 800 } 801 else if (e1 && e2) 802 { 803 i = gfc_dep_compare_expr (e1, e2); 804 if (i != 0) 805 return 0; 806 } 807 /* The strides match. */ 808 809 /* Check the range start. */ 810 e1 = ar1->start[n]; 811 e2 = ar2->start[n]; 812 if (e1 || e2) 813 { 814 /* Use the bound of the array if no bound is specified. */ 815 if (ar1->as && !e1) 816 e1 = ar1->as->lower[n]; 817 818 if (ar2->as && !e2) 819 e2 = ar2->as->lower[n]; 820 821 /* Check we have values for both. */ 822 if (!(e1 && e2)) 823 return 0; 824 825 i = gfc_dep_compare_expr (e1, e2); 826 if (i != 0) 827 return 0; 828 } 829 830 /* Check the range end. */ 831 e1 = ar1->end[n]; 832 e2 = ar2->end[n]; 833 if (e1 || e2) 834 { 835 /* Use the bound of the array if no bound is specified. */ 836 if (ar1->as && !e1) 837 e1 = ar1->as->upper[n]; 838 839 if (ar2->as && !e2) 840 e2 = ar2->as->upper[n]; 841 842 /* Check we have values for both. */ 843 if (!(e1 && e2)) 844 return 0; 845 846 i = gfc_dep_compare_expr (e1, e2); 847 if (i != 0) 848 return 0; 849 } 850 851 return 1; 852 } 853 854 855 /* Some array-returning intrinsics can be implemented by reusing the 856 data from one of the array arguments. For example, TRANSPOSE does 857 not necessarily need to allocate new data: it can be implemented 858 by copying the original array's descriptor and simply swapping the 859 two dimension specifications. 860 861 If EXPR is a call to such an intrinsic, return the argument 862 whose data can be reused, otherwise return NULL. */ 863 864 gfc_expr * 865 gfc_get_noncopying_intrinsic_argument (gfc_expr *expr) 866 { 867 if (expr->expr_type != EXPR_FUNCTION || !expr->value.function.isym) 868 return NULL; 869 870 switch (expr->value.function.isym->id) 871 { 872 case GFC_ISYM_TRANSPOSE: 873 return expr->value.function.actual->expr; 874 875 default: 876 return NULL; 877 } 878 } 879 880 881 /* Return true if the result of reference REF can only be constructed 882 using a temporary array. */ 883 884 bool 885 gfc_ref_needs_temporary_p (gfc_ref *ref) 886 { 887 int n; 888 bool subarray_p; 889 890 subarray_p = false; 891 for (; ref; ref = ref->next) 892 switch (ref->type) 893 { 894 case REF_ARRAY: 895 /* Vector dimensions are generally not monotonic and must be 896 handled using a temporary. */ 897 if (ref->u.ar.type == AR_SECTION) 898 for (n = 0; n < ref->u.ar.dimen; n++) 899 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) 900 return true; 901 902 subarray_p = true; 903 break; 904 905 case REF_SUBSTRING: 906 /* Within an array reference, character substrings generally 907 need a temporary. Character array strides are expressed as 908 multiples of the element size (consistent with other array 909 types), not in characters. */ 910 return subarray_p; 911 912 case REF_COMPONENT: 913 case REF_INQUIRY: 914 break; 915 } 916 917 return false; 918 } 919 920 921 static int 922 gfc_is_data_pointer (gfc_expr *e) 923 { 924 gfc_ref *ref; 925 926 if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION) 927 return 0; 928 929 /* No subreference if it is a function */ 930 gcc_assert (e->expr_type == EXPR_VARIABLE || !e->ref); 931 932 if (e->symtree->n.sym->attr.pointer) 933 return 1; 934 935 for (ref = e->ref; ref; ref = ref->next) 936 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 937 return 1; 938 939 return 0; 940 } 941 942 943 /* Return true if array variable VAR could be passed to the same function 944 as argument EXPR without interfering with EXPR. INTENT is the intent 945 of VAR. 946 947 This is considerably less conservative than other dependencies 948 because many function arguments will already be copied into a 949 temporary. */ 950 951 static int 952 gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent, 953 gfc_expr *expr, gfc_dep_check elemental) 954 { 955 gfc_expr *arg; 956 957 gcc_assert (var->expr_type == EXPR_VARIABLE); 958 gcc_assert (var->rank > 0); 959 960 switch (expr->expr_type) 961 { 962 case EXPR_VARIABLE: 963 /* In case of elemental subroutines, there is no dependency 964 between two same-range array references. */ 965 if (gfc_ref_needs_temporary_p (expr->ref) 966 || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) 967 { 968 if (elemental == ELEM_DONT_CHECK_VARIABLE) 969 { 970 /* Too many false positive with pointers. */ 971 if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) 972 { 973 /* Elemental procedures forbid unspecified intents, 974 and we don't check dependencies for INTENT_IN args. */ 975 gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); 976 977 /* We are told not to check dependencies. 978 We do it, however, and issue a warning in case we find one. 979 If a dependency is found in the case 980 elemental == ELEM_CHECK_VARIABLE, we will generate 981 a temporary, so we don't need to bother the user. */ 982 gfc_warning (0, "INTENT(%s) actual argument at %L might " 983 "interfere with actual argument at %L.", 984 intent == INTENT_OUT ? "OUT" : "INOUT", 985 &var->where, &expr->where); 986 } 987 return 0; 988 } 989 else 990 return 1; 991 } 992 return 0; 993 994 case EXPR_ARRAY: 995 /* the scalarizer always generates a temporary for array constructors, 996 so there is no dependency. */ 997 return 0; 998 999 case EXPR_FUNCTION: 1000 if (intent != INTENT_IN) 1001 { 1002 arg = gfc_get_noncopying_intrinsic_argument (expr); 1003 if (arg != NULL) 1004 return gfc_check_argument_var_dependency (var, intent, arg, 1005 NOT_ELEMENTAL); 1006 } 1007 1008 if (elemental != NOT_ELEMENTAL) 1009 { 1010 if ((expr->value.function.esym 1011 && expr->value.function.esym->attr.elemental) 1012 || (expr->value.function.isym 1013 && expr->value.function.isym->elemental)) 1014 return gfc_check_fncall_dependency (var, intent, NULL, 1015 expr->value.function.actual, 1016 ELEM_CHECK_VARIABLE); 1017 1018 if (gfc_inline_intrinsic_function_p (expr)) 1019 { 1020 /* The TRANSPOSE case should have been caught in the 1021 noncopying intrinsic case above. */ 1022 gcc_assert (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE); 1023 1024 return gfc_check_fncall_dependency (var, intent, NULL, 1025 expr->value.function.actual, 1026 ELEM_CHECK_VARIABLE); 1027 } 1028 } 1029 return 0; 1030 1031 case EXPR_OP: 1032 /* In case of non-elemental procedures, there is no need to catch 1033 dependencies, as we will make a temporary anyway. */ 1034 if (elemental) 1035 { 1036 /* If the actual arg EXPR is an expression, we need to catch 1037 a dependency between variables in EXPR and VAR, 1038 an intent((IN)OUT) variable. */ 1039 if (expr->value.op.op1 1040 && gfc_check_argument_var_dependency (var, intent, 1041 expr->value.op.op1, 1042 ELEM_CHECK_VARIABLE)) 1043 return 1; 1044 else if (expr->value.op.op2 1045 && gfc_check_argument_var_dependency (var, intent, 1046 expr->value.op.op2, 1047 ELEM_CHECK_VARIABLE)) 1048 return 1; 1049 } 1050 return 0; 1051 1052 default: 1053 return 0; 1054 } 1055 } 1056 1057 1058 /* Like gfc_check_argument_var_dependency, but extended to any 1059 array expression OTHER, not just variables. */ 1060 1061 static int 1062 gfc_check_argument_dependency (gfc_expr *other, sym_intent intent, 1063 gfc_expr *expr, gfc_dep_check elemental) 1064 { 1065 switch (other->expr_type) 1066 { 1067 case EXPR_VARIABLE: 1068 return gfc_check_argument_var_dependency (other, intent, expr, elemental); 1069 1070 case EXPR_FUNCTION: 1071 other = gfc_get_noncopying_intrinsic_argument (other); 1072 if (other != NULL) 1073 return gfc_check_argument_dependency (other, INTENT_IN, expr, 1074 NOT_ELEMENTAL); 1075 1076 return 0; 1077 1078 default: 1079 return 0; 1080 } 1081 } 1082 1083 1084 /* Like gfc_check_argument_dependency, but check all the arguments in ACTUAL. 1085 FNSYM is the function being called, or NULL if not known. */ 1086 1087 int 1088 gfc_check_fncall_dependency (gfc_expr *other, sym_intent intent, 1089 gfc_symbol *fnsym, gfc_actual_arglist *actual, 1090 gfc_dep_check elemental) 1091 { 1092 gfc_formal_arglist *formal; 1093 gfc_expr *expr; 1094 1095 formal = fnsym ? gfc_sym_get_dummy_args (fnsym) : NULL; 1096 for (; actual; actual = actual->next, formal = formal ? formal->next : NULL) 1097 { 1098 expr = actual->expr; 1099 1100 /* Skip args which are not present. */ 1101 if (!expr) 1102 continue; 1103 1104 /* Skip other itself. */ 1105 if (expr == other) 1106 continue; 1107 1108 /* Skip intent(in) arguments if OTHER itself is intent(in). */ 1109 if (formal && intent == INTENT_IN 1110 && formal->sym->attr.intent == INTENT_IN) 1111 continue; 1112 1113 if (gfc_check_argument_dependency (other, intent, expr, elemental)) 1114 return 1; 1115 } 1116 1117 return 0; 1118 } 1119 1120 1121 /* Return 1 if e1 and e2 are equivalenced arrays, either 1122 directly or indirectly; i.e., equivalence (a,b) for a and b 1123 or equivalence (a,c),(b,c). This function uses the equiv_ 1124 lists, generated in trans-common(add_equivalences), that are 1125 guaranteed to pick up indirect equivalences. We explicitly 1126 check for overlap using the offset and length of the equivalence. 1127 This function is symmetric. 1128 TODO: This function only checks whether the full top-level 1129 symbols overlap. An improved implementation could inspect 1130 e1->ref and e2->ref to determine whether the actually accessed 1131 portions of these variables/arrays potentially overlap. */ 1132 1133 int 1134 gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2) 1135 { 1136 gfc_equiv_list *l; 1137 gfc_equiv_info *s, *fl1, *fl2; 1138 1139 gcc_assert (e1->expr_type == EXPR_VARIABLE 1140 && e2->expr_type == EXPR_VARIABLE); 1141 1142 if (!e1->symtree->n.sym->attr.in_equivalence 1143 || !e2->symtree->n.sym->attr.in_equivalence|| !e1->rank || !e2->rank) 1144 return 0; 1145 1146 if (e1->symtree->n.sym->ns 1147 && e1->symtree->n.sym->ns != gfc_current_ns) 1148 l = e1->symtree->n.sym->ns->equiv_lists; 1149 else 1150 l = gfc_current_ns->equiv_lists; 1151 1152 /* Go through the equiv_lists and return 1 if the variables 1153 e1 and e2 are members of the same group and satisfy the 1154 requirement on their relative offsets. */ 1155 for (; l; l = l->next) 1156 { 1157 fl1 = NULL; 1158 fl2 = NULL; 1159 for (s = l->equiv; s; s = s->next) 1160 { 1161 if (s->sym == e1->symtree->n.sym) 1162 { 1163 fl1 = s; 1164 if (fl2) 1165 break; 1166 } 1167 if (s->sym == e2->symtree->n.sym) 1168 { 1169 fl2 = s; 1170 if (fl1) 1171 break; 1172 } 1173 } 1174 1175 if (s) 1176 { 1177 /* Can these lengths be zero? */ 1178 if (fl1->length <= 0 || fl2->length <= 0) 1179 return 1; 1180 /* These can't overlap if [f11,fl1+length] is before 1181 [fl2,fl2+length], or [fl2,fl2+length] is before 1182 [fl1,fl1+length], otherwise they do overlap. */ 1183 if (fl1->offset + fl1->length > fl2->offset 1184 && fl2->offset + fl2->length > fl1->offset) 1185 return 1; 1186 } 1187 } 1188 return 0; 1189 } 1190 1191 1192 /* Return true if there is no possibility of aliasing because of a type 1193 mismatch between all the possible pointer references and the 1194 potential target. Note that this function is asymmetric in the 1195 arguments and so must be called twice with the arguments exchanged. */ 1196 1197 static bool 1198 check_data_pointer_types (gfc_expr *expr1, gfc_expr *expr2) 1199 { 1200 gfc_component *cm1; 1201 gfc_symbol *sym1; 1202 gfc_symbol *sym2; 1203 gfc_ref *ref1; 1204 bool seen_component_ref; 1205 1206 if (expr1->expr_type != EXPR_VARIABLE 1207 || expr2->expr_type != EXPR_VARIABLE) 1208 return false; 1209 1210 sym1 = expr1->symtree->n.sym; 1211 sym2 = expr2->symtree->n.sym; 1212 1213 /* Keep it simple for now. */ 1214 if (sym1->ts.type == BT_DERIVED && sym2->ts.type == BT_DERIVED) 1215 return false; 1216 1217 if (sym1->attr.pointer) 1218 { 1219 if (gfc_compare_types (&sym1->ts, &sym2->ts)) 1220 return false; 1221 } 1222 1223 /* This is a conservative check on the components of the derived type 1224 if no component references have been seen. Since we will not dig 1225 into the components of derived type components, we play it safe by 1226 returning false. First we check the reference chain and then, if 1227 no component references have been seen, the components. */ 1228 seen_component_ref = false; 1229 if (sym1->ts.type == BT_DERIVED) 1230 { 1231 for (ref1 = expr1->ref; ref1; ref1 = ref1->next) 1232 { 1233 if (ref1->type != REF_COMPONENT) 1234 continue; 1235 1236 if (ref1->u.c.component->ts.type == BT_DERIVED) 1237 return false; 1238 1239 if ((sym2->attr.pointer || ref1->u.c.component->attr.pointer) 1240 && gfc_compare_types (&ref1->u.c.component->ts, &sym2->ts)) 1241 return false; 1242 1243 seen_component_ref = true; 1244 } 1245 } 1246 1247 if (sym1->ts.type == BT_DERIVED && !seen_component_ref) 1248 { 1249 for (cm1 = sym1->ts.u.derived->components; cm1; cm1 = cm1->next) 1250 { 1251 if (cm1->ts.type == BT_DERIVED) 1252 return false; 1253 1254 if ((sym2->attr.pointer || cm1->attr.pointer) 1255 && gfc_compare_types (&cm1->ts, &sym2->ts)) 1256 return false; 1257 } 1258 } 1259 1260 return true; 1261 } 1262 1263 1264 /* Return true if the statement body redefines the condition. Returns 1265 true if expr2 depends on expr1. expr1 should be a single term 1266 suitable for the lhs of an assignment. The IDENTICAL flag indicates 1267 whether array references to the same symbol with identical range 1268 references count as a dependency or not. Used for forall and where 1269 statements. Also used with functions returning arrays without a 1270 temporary. */ 1271 1272 int 1273 gfc_check_dependency (gfc_expr *expr1, gfc_expr *expr2, bool identical) 1274 { 1275 gfc_actual_arglist *actual; 1276 gfc_constructor *c; 1277 int n; 1278 1279 /* -fcoarray=lib can end up here with expr1->expr_type set to EXPR_FUNCTION 1280 and a reference to _F.caf_get, so skip the assert. */ 1281 if (expr1->expr_type == EXPR_FUNCTION 1282 && strcmp (expr1->value.function.name, "_F.caf_get") == 0) 1283 return 0; 1284 1285 if (expr1->expr_type != EXPR_VARIABLE) 1286 gfc_internal_error ("gfc_check_dependency: expecting an EXPR_VARIABLE"); 1287 1288 switch (expr2->expr_type) 1289 { 1290 case EXPR_OP: 1291 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); 1292 if (n) 1293 return n; 1294 if (expr2->value.op.op2) 1295 return gfc_check_dependency (expr1, expr2->value.op.op2, identical); 1296 return 0; 1297 1298 case EXPR_VARIABLE: 1299 /* The interesting cases are when the symbols don't match. */ 1300 if (expr1->symtree->n.sym != expr2->symtree->n.sym) 1301 { 1302 symbol_attribute attr1, attr2; 1303 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; 1304 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; 1305 1306 /* Return 1 if expr1 and expr2 are equivalenced arrays. */ 1307 if (gfc_are_equivalenced_arrays (expr1, expr2)) 1308 return 1; 1309 1310 /* Symbols can only alias if they have the same type. */ 1311 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN 1312 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) 1313 { 1314 if (ts1->type != ts2->type || ts1->kind != ts2->kind) 1315 return 0; 1316 } 1317 1318 /* We have to also include target-target as ptr%comp is not a 1319 pointer but it still alias with "dt%comp" for "ptr => dt". As 1320 subcomponents and array access to pointers retains the target 1321 attribute, that's sufficient. */ 1322 attr1 = gfc_expr_attr (expr1); 1323 attr2 = gfc_expr_attr (expr2); 1324 if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target)) 1325 { 1326 if (check_data_pointer_types (expr1, expr2) 1327 && check_data_pointer_types (expr2, expr1)) 1328 return 0; 1329 1330 return 1; 1331 } 1332 else 1333 { 1334 gfc_symbol *sym1 = expr1->symtree->n.sym; 1335 gfc_symbol *sym2 = expr2->symtree->n.sym; 1336 if (sym1->attr.target && sym2->attr.target 1337 && ((sym1->attr.dummy && !sym1->attr.contiguous 1338 && (!sym1->attr.dimension 1339 || sym2->as->type == AS_ASSUMED_SHAPE)) 1340 || (sym2->attr.dummy && !sym2->attr.contiguous 1341 && (!sym2->attr.dimension 1342 || sym2->as->type == AS_ASSUMED_SHAPE)))) 1343 return 1; 1344 } 1345 1346 /* Otherwise distinct symbols have no dependencies. */ 1347 return 0; 1348 } 1349 1350 if (identical) 1351 return 1; 1352 1353 /* Identical and disjoint ranges return 0, 1354 overlapping ranges return 1. */ 1355 if (expr1->ref && expr2->ref) 1356 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL); 1357 1358 return 1; 1359 1360 case EXPR_FUNCTION: 1361 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL) 1362 identical = 1; 1363 1364 /* Remember possible differences between elemental and 1365 transformational functions. All functions inside a FORALL 1366 will be pure. */ 1367 for (actual = expr2->value.function.actual; 1368 actual; actual = actual->next) 1369 { 1370 if (!actual->expr) 1371 continue; 1372 n = gfc_check_dependency (expr1, actual->expr, identical); 1373 if (n) 1374 return n; 1375 } 1376 return 0; 1377 1378 case EXPR_CONSTANT: 1379 case EXPR_NULL: 1380 return 0; 1381 1382 case EXPR_ARRAY: 1383 /* Loop through the array constructor's elements. */ 1384 for (c = gfc_constructor_first (expr2->value.constructor); 1385 c; c = gfc_constructor_next (c)) 1386 { 1387 /* If this is an iterator, assume the worst. */ 1388 if (c->iterator) 1389 return 1; 1390 /* Avoid recursion in the common case. */ 1391 if (c->expr->expr_type == EXPR_CONSTANT) 1392 continue; 1393 if (gfc_check_dependency (expr1, c->expr, 1)) 1394 return 1; 1395 } 1396 return 0; 1397 1398 default: 1399 return 1; 1400 } 1401 } 1402 1403 1404 /* Determines overlapping for two array sections. */ 1405 1406 static gfc_dependency 1407 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) 1408 { 1409 gfc_expr *l_start; 1410 gfc_expr *l_end; 1411 gfc_expr *l_stride; 1412 gfc_expr *l_lower; 1413 gfc_expr *l_upper; 1414 int l_dir; 1415 1416 gfc_expr *r_start; 1417 gfc_expr *r_end; 1418 gfc_expr *r_stride; 1419 gfc_expr *r_lower; 1420 gfc_expr *r_upper; 1421 gfc_expr *one_expr; 1422 int r_dir; 1423 int stride_comparison; 1424 int start_comparison; 1425 mpz_t tmp; 1426 1427 /* If they are the same range, return without more ado. */ 1428 if (is_same_range (l_ar, r_ar, n)) 1429 return GFC_DEP_EQUAL; 1430 1431 l_start = l_ar->start[n]; 1432 l_end = l_ar->end[n]; 1433 l_stride = l_ar->stride[n]; 1434 1435 r_start = r_ar->start[n]; 1436 r_end = r_ar->end[n]; 1437 r_stride = r_ar->stride[n]; 1438 1439 /* If l_start is NULL take it from array specifier. */ 1440 if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) 1441 l_start = l_ar->as->lower[n]; 1442 /* If l_end is NULL take it from array specifier. */ 1443 if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) 1444 l_end = l_ar->as->upper[n]; 1445 1446 /* If r_start is NULL take it from array specifier. */ 1447 if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) 1448 r_start = r_ar->as->lower[n]; 1449 /* If r_end is NULL take it from array specifier. */ 1450 if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) 1451 r_end = r_ar->as->upper[n]; 1452 1453 /* Determine whether the l_stride is positive or negative. */ 1454 if (!l_stride) 1455 l_dir = 1; 1456 else if (l_stride->expr_type == EXPR_CONSTANT 1457 && l_stride->ts.type == BT_INTEGER) 1458 l_dir = mpz_sgn (l_stride->value.integer); 1459 else if (l_start && l_end) 1460 l_dir = gfc_dep_compare_expr (l_end, l_start); 1461 else 1462 l_dir = -2; 1463 1464 /* Determine whether the r_stride is positive or negative. */ 1465 if (!r_stride) 1466 r_dir = 1; 1467 else if (r_stride->expr_type == EXPR_CONSTANT 1468 && r_stride->ts.type == BT_INTEGER) 1469 r_dir = mpz_sgn (r_stride->value.integer); 1470 else if (r_start && r_end) 1471 r_dir = gfc_dep_compare_expr (r_end, r_start); 1472 else 1473 r_dir = -2; 1474 1475 /* The strides should never be zero. */ 1476 if (l_dir == 0 || r_dir == 0) 1477 return GFC_DEP_OVERLAP; 1478 1479 /* Determine the relationship between the strides. Set stride_comparison to 1480 -2 if the dependency cannot be determined 1481 -1 if l_stride < r_stride 1482 0 if l_stride == r_stride 1483 1 if l_stride > r_stride 1484 as determined by gfc_dep_compare_expr. */ 1485 1486 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1487 1488 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr, 1489 r_stride ? r_stride : one_expr); 1490 1491 if (l_start && r_start) 1492 start_comparison = gfc_dep_compare_expr (l_start, r_start); 1493 else 1494 start_comparison = -2; 1495 1496 gfc_free_expr (one_expr); 1497 1498 /* Determine LHS upper and lower bounds. */ 1499 if (l_dir == 1) 1500 { 1501 l_lower = l_start; 1502 l_upper = l_end; 1503 } 1504 else if (l_dir == -1) 1505 { 1506 l_lower = l_end; 1507 l_upper = l_start; 1508 } 1509 else 1510 { 1511 l_lower = NULL; 1512 l_upper = NULL; 1513 } 1514 1515 /* Determine RHS upper and lower bounds. */ 1516 if (r_dir == 1) 1517 { 1518 r_lower = r_start; 1519 r_upper = r_end; 1520 } 1521 else if (r_dir == -1) 1522 { 1523 r_lower = r_end; 1524 r_upper = r_start; 1525 } 1526 else 1527 { 1528 r_lower = NULL; 1529 r_upper = NULL; 1530 } 1531 1532 /* Check whether the ranges are disjoint. */ 1533 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1) 1534 return GFC_DEP_NODEP; 1535 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1) 1536 return GFC_DEP_NODEP; 1537 1538 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */ 1539 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0) 1540 { 1541 if (l_dir == 1 && r_dir == -1) 1542 return GFC_DEP_EQUAL; 1543 if (l_dir == -1 && r_dir == 1) 1544 return GFC_DEP_EQUAL; 1545 } 1546 1547 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */ 1548 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0) 1549 { 1550 if (l_dir == 1 && r_dir == -1) 1551 return GFC_DEP_EQUAL; 1552 if (l_dir == -1 && r_dir == 1) 1553 return GFC_DEP_EQUAL; 1554 } 1555 1556 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP. 1557 There is no dependency if the remainder of 1558 (l_start - r_start) / gcd(l_stride, r_stride) is 1559 nonzero. 1560 TODO: 1561 - Cases like a(1:4:2) = a(2:3) are still not handled. 1562 */ 1563 1564 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ 1565 && (a)->ts.type == BT_INTEGER) 1566 1567 if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride) 1568 && gfc_dep_difference (l_start, r_start, &tmp)) 1569 { 1570 mpz_t gcd; 1571 int result; 1572 1573 mpz_init (gcd); 1574 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); 1575 1576 mpz_fdiv_r (tmp, tmp, gcd); 1577 result = mpz_cmp_si (tmp, 0L); 1578 1579 mpz_clear (gcd); 1580 mpz_clear (tmp); 1581 1582 if (result != 0) 1583 return GFC_DEP_NODEP; 1584 } 1585 1586 #undef IS_CONSTANT_INTEGER 1587 1588 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */ 1589 1590 if (l_dir == 1 && r_dir == 1 && 1591 (start_comparison == 0 || start_comparison == -1) 1592 && (stride_comparison == 0 || stride_comparison == -1)) 1593 return GFC_DEP_FORWARD; 1594 1595 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and 1596 x:y:-1 vs. x:y:-2. */ 1597 if (l_dir == -1 && r_dir == -1 && 1598 (start_comparison == 0 || start_comparison == 1) 1599 && (stride_comparison == 0 || stride_comparison == 1)) 1600 return GFC_DEP_FORWARD; 1601 1602 if (stride_comparison == 0 || stride_comparison == -1) 1603 { 1604 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) 1605 { 1606 1607 /* Check for a(low:y:s) vs. a(z:x:s) or 1608 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound 1609 of low, which is always at least a forward dependence. */ 1610 1611 if (r_dir == 1 1612 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) 1613 return GFC_DEP_FORWARD; 1614 } 1615 } 1616 1617 if (stride_comparison == 0 || stride_comparison == 1) 1618 { 1619 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) 1620 { 1621 1622 /* Check for a(high:y:-s) vs. a(z:x:-s) or 1623 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound 1624 of high, which is always at least a forward dependence. */ 1625 1626 if (r_dir == -1 1627 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0) 1628 return GFC_DEP_FORWARD; 1629 } 1630 } 1631 1632 1633 if (stride_comparison == 0) 1634 { 1635 /* From here, check for backwards dependencies. */ 1636 /* x+1:y vs. x:z. */ 1637 if (l_dir == 1 && r_dir == 1 && start_comparison == 1) 1638 return GFC_DEP_BACKWARD; 1639 1640 /* x-1:y:-1 vs. x:z:-1. */ 1641 if (l_dir == -1 && r_dir == -1 && start_comparison == -1) 1642 return GFC_DEP_BACKWARD; 1643 } 1644 1645 return GFC_DEP_OVERLAP; 1646 } 1647 1648 1649 /* Determines overlapping for a single element and a section. */ 1650 1651 static gfc_dependency 1652 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n) 1653 { 1654 gfc_array_ref *ref; 1655 gfc_expr *elem; 1656 gfc_expr *start; 1657 gfc_expr *end; 1658 gfc_expr *stride; 1659 int s; 1660 1661 elem = lref->u.ar.start[n]; 1662 if (!elem) 1663 return GFC_DEP_OVERLAP; 1664 1665 ref = &rref->u.ar; 1666 start = ref->start[n] ; 1667 end = ref->end[n] ; 1668 stride = ref->stride[n]; 1669 1670 if (!start && IS_ARRAY_EXPLICIT (ref->as)) 1671 start = ref->as->lower[n]; 1672 if (!end && IS_ARRAY_EXPLICIT (ref->as)) 1673 end = ref->as->upper[n]; 1674 1675 /* Determine whether the stride is positive or negative. */ 1676 if (!stride) 1677 s = 1; 1678 else if (stride->expr_type == EXPR_CONSTANT 1679 && stride->ts.type == BT_INTEGER) 1680 s = mpz_sgn (stride->value.integer); 1681 else 1682 s = -2; 1683 1684 /* Stride should never be zero. */ 1685 if (s == 0) 1686 return GFC_DEP_OVERLAP; 1687 1688 /* Positive strides. */ 1689 if (s == 1) 1690 { 1691 /* Check for elem < lower. */ 1692 if (start && gfc_dep_compare_expr (elem, start) == -1) 1693 return GFC_DEP_NODEP; 1694 /* Check for elem > upper. */ 1695 if (end && gfc_dep_compare_expr (elem, end) == 1) 1696 return GFC_DEP_NODEP; 1697 1698 if (start && end) 1699 { 1700 s = gfc_dep_compare_expr (start, end); 1701 /* Check for an empty range. */ 1702 if (s == 1) 1703 return GFC_DEP_NODEP; 1704 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) 1705 return GFC_DEP_EQUAL; 1706 } 1707 } 1708 /* Negative strides. */ 1709 else if (s == -1) 1710 { 1711 /* Check for elem > upper. */ 1712 if (end && gfc_dep_compare_expr (elem, start) == 1) 1713 return GFC_DEP_NODEP; 1714 /* Check for elem < lower. */ 1715 if (start && gfc_dep_compare_expr (elem, end) == -1) 1716 return GFC_DEP_NODEP; 1717 1718 if (start && end) 1719 { 1720 s = gfc_dep_compare_expr (start, end); 1721 /* Check for an empty range. */ 1722 if (s == -1) 1723 return GFC_DEP_NODEP; 1724 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) 1725 return GFC_DEP_EQUAL; 1726 } 1727 } 1728 /* Unknown strides. */ 1729 else 1730 { 1731 if (!start || !end) 1732 return GFC_DEP_OVERLAP; 1733 s = gfc_dep_compare_expr (start, end); 1734 if (s <= -2) 1735 return GFC_DEP_OVERLAP; 1736 /* Assume positive stride. */ 1737 if (s == -1) 1738 { 1739 /* Check for elem < lower. */ 1740 if (gfc_dep_compare_expr (elem, start) == -1) 1741 return GFC_DEP_NODEP; 1742 /* Check for elem > upper. */ 1743 if (gfc_dep_compare_expr (elem, end) == 1) 1744 return GFC_DEP_NODEP; 1745 } 1746 /* Assume negative stride. */ 1747 else if (s == 1) 1748 { 1749 /* Check for elem > upper. */ 1750 if (gfc_dep_compare_expr (elem, start) == 1) 1751 return GFC_DEP_NODEP; 1752 /* Check for elem < lower. */ 1753 if (gfc_dep_compare_expr (elem, end) == -1) 1754 return GFC_DEP_NODEP; 1755 } 1756 /* Equal bounds. */ 1757 else if (s == 0) 1758 { 1759 s = gfc_dep_compare_expr (elem, start); 1760 if (s == 0) 1761 return GFC_DEP_EQUAL; 1762 if (s == 1 || s == -1) 1763 return GFC_DEP_NODEP; 1764 } 1765 } 1766 1767 return GFC_DEP_OVERLAP; 1768 } 1769 1770 1771 /* Traverse expr, checking all EXPR_VARIABLE symbols for their 1772 forall_index attribute. Return true if any variable may be 1773 being used as a FORALL index. Its safe to pessimistically 1774 return true, and assume a dependency. */ 1775 1776 static bool 1777 contains_forall_index_p (gfc_expr *expr) 1778 { 1779 gfc_actual_arglist *arg; 1780 gfc_constructor *c; 1781 gfc_ref *ref; 1782 int i; 1783 1784 if (!expr) 1785 return false; 1786 1787 switch (expr->expr_type) 1788 { 1789 case EXPR_VARIABLE: 1790 if (expr->symtree->n.sym->forall_index) 1791 return true; 1792 break; 1793 1794 case EXPR_OP: 1795 if (contains_forall_index_p (expr->value.op.op1) 1796 || contains_forall_index_p (expr->value.op.op2)) 1797 return true; 1798 break; 1799 1800 case EXPR_FUNCTION: 1801 for (arg = expr->value.function.actual; arg; arg = arg->next) 1802 if (contains_forall_index_p (arg->expr)) 1803 return true; 1804 break; 1805 1806 case EXPR_CONSTANT: 1807 case EXPR_NULL: 1808 case EXPR_SUBSTRING: 1809 break; 1810 1811 case EXPR_STRUCTURE: 1812 case EXPR_ARRAY: 1813 for (c = gfc_constructor_first (expr->value.constructor); 1814 c; gfc_constructor_next (c)) 1815 if (contains_forall_index_p (c->expr)) 1816 return true; 1817 break; 1818 1819 default: 1820 gcc_unreachable (); 1821 } 1822 1823 for (ref = expr->ref; ref; ref = ref->next) 1824 switch (ref->type) 1825 { 1826 case REF_ARRAY: 1827 for (i = 0; i < ref->u.ar.dimen; i++) 1828 if (contains_forall_index_p (ref->u.ar.start[i]) 1829 || contains_forall_index_p (ref->u.ar.end[i]) 1830 || contains_forall_index_p (ref->u.ar.stride[i])) 1831 return true; 1832 break; 1833 1834 case REF_COMPONENT: 1835 break; 1836 1837 case REF_SUBSTRING: 1838 if (contains_forall_index_p (ref->u.ss.start) 1839 || contains_forall_index_p (ref->u.ss.end)) 1840 return true; 1841 break; 1842 1843 default: 1844 gcc_unreachable (); 1845 } 1846 1847 return false; 1848 } 1849 1850 /* Determines overlapping for two single element array references. */ 1851 1852 static gfc_dependency 1853 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n) 1854 { 1855 gfc_array_ref l_ar; 1856 gfc_array_ref r_ar; 1857 gfc_expr *l_start; 1858 gfc_expr *r_start; 1859 int i; 1860 1861 l_ar = lref->u.ar; 1862 r_ar = rref->u.ar; 1863 l_start = l_ar.start[n] ; 1864 r_start = r_ar.start[n] ; 1865 i = gfc_dep_compare_expr (r_start, l_start); 1866 if (i == 0) 1867 return GFC_DEP_EQUAL; 1868 1869 /* Treat two scalar variables as potentially equal. This allows 1870 us to prove that a(i,:) and a(j,:) have no dependency. See 1871 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis", 1872 Proceedings of the International Conference on Parallel and 1873 Distributed Processing Techniques and Applications (PDPTA2001), 1874 Las Vegas, Nevada, June 2001. */ 1875 /* However, we need to be careful when either scalar expression 1876 contains a FORALL index, as these can potentially change value 1877 during the scalarization/traversal of this array reference. */ 1878 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start)) 1879 return GFC_DEP_OVERLAP; 1880 1881 if (i > -2) 1882 return GFC_DEP_NODEP; 1883 return GFC_DEP_EQUAL; 1884 } 1885 1886 /* Callback function for checking if an expression depends on a 1887 dummy variable which is any other than INTENT(IN). */ 1888 1889 static int 1890 callback_dummy_intent_not_in (gfc_expr **ep, 1891 int *walk_subtrees ATTRIBUTE_UNUSED, 1892 void *data ATTRIBUTE_UNUSED) 1893 { 1894 gfc_expr *e = *ep; 1895 1896 if (e->expr_type == EXPR_VARIABLE && e->symtree 1897 && e->symtree->n.sym->attr.dummy) 1898 return e->symtree->n.sym->attr.intent != INTENT_IN; 1899 else 1900 return 0; 1901 } 1902 1903 /* Auxiliary function to check if subexpressions have dummy variables which 1904 are not intent(in). 1905 */ 1906 1907 static bool 1908 dummy_intent_not_in (gfc_expr **ep) 1909 { 1910 return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL); 1911 } 1912 1913 /* Determine if an array ref, usually an array section specifies the 1914 entire array. In addition, if the second, pointer argument is 1915 provided, the function will return true if the reference is 1916 contiguous; eg. (:, 1) gives true but (1,:) gives false. 1917 If one of the bounds depends on a dummy variable which is 1918 not INTENT(IN), also return false, because the user may 1919 have changed the variable. */ 1920 1921 bool 1922 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) 1923 { 1924 int i; 1925 int n; 1926 bool lbound_OK = true; 1927 bool ubound_OK = true; 1928 1929 if (contiguous) 1930 *contiguous = false; 1931 1932 if (ref->type != REF_ARRAY) 1933 return false; 1934 1935 if (ref->u.ar.type == AR_FULL) 1936 { 1937 if (contiguous) 1938 *contiguous = true; 1939 return true; 1940 } 1941 1942 if (ref->u.ar.type != AR_SECTION) 1943 return false; 1944 if (ref->next) 1945 return false; 1946 1947 for (i = 0; i < ref->u.ar.dimen; i++) 1948 { 1949 /* If we have a single element in the reference, for the reference 1950 to be full, we need to ascertain that the array has a single 1951 element in this dimension and that we actually reference the 1952 correct element. */ 1953 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) 1954 { 1955 /* This is unconditionally a contiguous reference if all the 1956 remaining dimensions are elements. */ 1957 if (contiguous) 1958 { 1959 *contiguous = true; 1960 for (n = i + 1; n < ref->u.ar.dimen; n++) 1961 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 1962 *contiguous = false; 1963 } 1964 1965 if (!ref->u.ar.as 1966 || !ref->u.ar.as->lower[i] 1967 || !ref->u.ar.as->upper[i] 1968 || gfc_dep_compare_expr (ref->u.ar.as->lower[i], 1969 ref->u.ar.as->upper[i]) 1970 || !ref->u.ar.start[i] 1971 || gfc_dep_compare_expr (ref->u.ar.start[i], 1972 ref->u.ar.as->lower[i])) 1973 return false; 1974 else 1975 continue; 1976 } 1977 1978 /* Check the lower bound. */ 1979 if (ref->u.ar.start[i] 1980 && (!ref->u.ar.as 1981 || !ref->u.ar.as->lower[i] 1982 || gfc_dep_compare_expr (ref->u.ar.start[i], 1983 ref->u.ar.as->lower[i]) 1984 || dummy_intent_not_in (&ref->u.ar.start[i]))) 1985 lbound_OK = false; 1986 /* Check the upper bound. */ 1987 if (ref->u.ar.end[i] 1988 && (!ref->u.ar.as 1989 || !ref->u.ar.as->upper[i] 1990 || gfc_dep_compare_expr (ref->u.ar.end[i], 1991 ref->u.ar.as->upper[i]) 1992 || dummy_intent_not_in (&ref->u.ar.end[i]))) 1993 ubound_OK = false; 1994 /* Check the stride. */ 1995 if (ref->u.ar.stride[i] 1996 && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) 1997 return false; 1998 1999 /* This is unconditionally a contiguous reference as long as all 2000 the subsequent dimensions are elements. */ 2001 if (contiguous) 2002 { 2003 *contiguous = true; 2004 for (n = i + 1; n < ref->u.ar.dimen; n++) 2005 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 2006 *contiguous = false; 2007 } 2008 2009 if (!lbound_OK || !ubound_OK) 2010 return false; 2011 } 2012 return true; 2013 } 2014 2015 2016 /* Determine if a full array is the same as an array section with one 2017 variable limit. For this to be so, the strides must both be unity 2018 and one of either start == lower or end == upper must be true. */ 2019 2020 static bool 2021 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) 2022 { 2023 int i; 2024 bool upper_or_lower; 2025 2026 if (full_ref->type != REF_ARRAY) 2027 return false; 2028 if (full_ref->u.ar.type != AR_FULL) 2029 return false; 2030 if (ref->type != REF_ARRAY) 2031 return false; 2032 if (ref->u.ar.type != AR_SECTION) 2033 return false; 2034 2035 for (i = 0; i < ref->u.ar.dimen; i++) 2036 { 2037 /* If we have a single element in the reference, we need to check 2038 that the array has a single element and that we actually reference 2039 the correct element. */ 2040 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) 2041 { 2042 if (!full_ref->u.ar.as 2043 || !full_ref->u.ar.as->lower[i] 2044 || !full_ref->u.ar.as->upper[i] 2045 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i], 2046 full_ref->u.ar.as->upper[i]) 2047 || !ref->u.ar.start[i] 2048 || gfc_dep_compare_expr (ref->u.ar.start[i], 2049 full_ref->u.ar.as->lower[i])) 2050 return false; 2051 } 2052 2053 /* Check the strides. */ 2054 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0)) 2055 return false; 2056 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) 2057 return false; 2058 2059 upper_or_lower = false; 2060 /* Check the lower bound. */ 2061 if (ref->u.ar.start[i] 2062 && (ref->u.ar.as 2063 && full_ref->u.ar.as->lower[i] 2064 && gfc_dep_compare_expr (ref->u.ar.start[i], 2065 full_ref->u.ar.as->lower[i]) == 0)) 2066 upper_or_lower = true; 2067 /* Check the upper bound. */ 2068 if (ref->u.ar.end[i] 2069 && (ref->u.ar.as 2070 && full_ref->u.ar.as->upper[i] 2071 && gfc_dep_compare_expr (ref->u.ar.end[i], 2072 full_ref->u.ar.as->upper[i]) == 0)) 2073 upper_or_lower = true; 2074 if (!upper_or_lower) 2075 return false; 2076 } 2077 return true; 2078 } 2079 2080 2081 /* Finds if two array references are overlapping or not. 2082 Return value 2083 2 : array references are overlapping but reversal of one or 2084 more dimensions will clear the dependency. 2085 1 : array references are overlapping. 2086 0 : array references are identical or not overlapping. */ 2087 2088 int 2089 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse) 2090 { 2091 int n; 2092 int m; 2093 gfc_dependency fin_dep; 2094 gfc_dependency this_dep; 2095 2096 this_dep = GFC_DEP_ERROR; 2097 fin_dep = GFC_DEP_ERROR; 2098 /* Dependencies due to pointers should already have been identified. 2099 We only need to check for overlapping array references. */ 2100 2101 while (lref && rref) 2102 { 2103 /* We're resolving from the same base symbol, so both refs should be 2104 the same type. We traverse the reference chain until we find ranges 2105 that are not equal. */ 2106 gcc_assert (lref->type == rref->type); 2107 switch (lref->type) 2108 { 2109 case REF_COMPONENT: 2110 /* The two ranges can't overlap if they are from different 2111 components. */ 2112 if (lref->u.c.component != rref->u.c.component) 2113 return 0; 2114 break; 2115 2116 case REF_SUBSTRING: 2117 /* Substring overlaps are handled by the string assignment code 2118 if there is not an underlying dependency. */ 2119 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; 2120 2121 case REF_ARRAY: 2122 2123 if (ref_same_as_full_array (lref, rref)) 2124 return 0; 2125 2126 if (ref_same_as_full_array (rref, lref)) 2127 return 0; 2128 2129 if (lref->u.ar.dimen != rref->u.ar.dimen) 2130 { 2131 if (lref->u.ar.type == AR_FULL) 2132 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL 2133 : GFC_DEP_OVERLAP; 2134 else if (rref->u.ar.type == AR_FULL) 2135 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL 2136 : GFC_DEP_OVERLAP; 2137 else 2138 return 1; 2139 break; 2140 } 2141 2142 /* Index for the reverse array. */ 2143 m = -1; 2144 for (n=0; n < lref->u.ar.dimen; n++) 2145 { 2146 /* Handle dependency when either of array reference is vector 2147 subscript. There is no dependency if the vector indices 2148 are equal or if indices are known to be different in a 2149 different dimension. */ 2150 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR 2151 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) 2152 { 2153 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR 2154 && rref->u.ar.dimen_type[n] == DIMEN_VECTOR 2155 && gfc_dep_compare_expr (lref->u.ar.start[n], 2156 rref->u.ar.start[n]) == 0) 2157 this_dep = GFC_DEP_EQUAL; 2158 else 2159 this_dep = GFC_DEP_OVERLAP; 2160 2161 goto update_fin_dep; 2162 } 2163 2164 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE 2165 && rref->u.ar.dimen_type[n] == DIMEN_RANGE) 2166 this_dep = check_section_vs_section (&lref->u.ar, &rref->u.ar, n); 2167 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2168 && rref->u.ar.dimen_type[n] == DIMEN_RANGE) 2169 this_dep = gfc_check_element_vs_section (lref, rref, n); 2170 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2171 && lref->u.ar.dimen_type[n] == DIMEN_RANGE) 2172 this_dep = gfc_check_element_vs_section (rref, lref, n); 2173 else 2174 { 2175 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2176 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); 2177 this_dep = gfc_check_element_vs_element (rref, lref, n); 2178 } 2179 2180 /* If any dimension doesn't overlap, we have no dependency. */ 2181 if (this_dep == GFC_DEP_NODEP) 2182 return 0; 2183 2184 /* Now deal with the loop reversal logic: This only works on 2185 ranges and is activated by setting 2186 reverse[n] == GFC_ENABLE_REVERSE 2187 The ability to reverse or not is set by previous conditions 2188 in this dimension. If reversal is not activated, the 2189 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ 2190 2191 /* Get the indexing right for the scalarizing loop. If this 2192 is an element, there is no corresponding loop. */ 2193 if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 2194 m++; 2195 2196 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE 2197 && lref->u.ar.dimen_type[n] == DIMEN_RANGE) 2198 { 2199 /* Set reverse if backward dependence and not inhibited. */ 2200 if (reverse && reverse[m] == GFC_ENABLE_REVERSE) 2201 reverse[m] = (this_dep == GFC_DEP_BACKWARD) ? 2202 GFC_REVERSE_SET : reverse[m]; 2203 2204 /* Set forward if forward dependence and not inhibited. */ 2205 if (reverse && reverse[m] == GFC_ENABLE_REVERSE) 2206 reverse[m] = (this_dep == GFC_DEP_FORWARD) ? 2207 GFC_FORWARD_SET : reverse[m]; 2208 2209 /* Flag up overlap if dependence not compatible with 2210 the overall state of the expression. */ 2211 if (reverse && reverse[m] == GFC_REVERSE_SET 2212 && this_dep == GFC_DEP_FORWARD) 2213 { 2214 reverse[m] = GFC_INHIBIT_REVERSE; 2215 this_dep = GFC_DEP_OVERLAP; 2216 } 2217 else if (reverse && reverse[m] == GFC_FORWARD_SET 2218 && this_dep == GFC_DEP_BACKWARD) 2219 { 2220 reverse[m] = GFC_INHIBIT_REVERSE; 2221 this_dep = GFC_DEP_OVERLAP; 2222 } 2223 2224 /* If no intention of reversing or reversing is explicitly 2225 inhibited, convert backward dependence to overlap. */ 2226 if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD) 2227 || (reverse != NULL && reverse[m] == GFC_INHIBIT_REVERSE)) 2228 this_dep = GFC_DEP_OVERLAP; 2229 } 2230 2231 /* Overlap codes are in order of priority. We only need to 2232 know the worst one.*/ 2233 2234 update_fin_dep: 2235 if (this_dep > fin_dep) 2236 fin_dep = this_dep; 2237 } 2238 2239 /* If this is an equal element, we have to keep going until we find 2240 the "real" array reference. */ 2241 if (lref->u.ar.type == AR_ELEMENT 2242 && rref->u.ar.type == AR_ELEMENT 2243 && fin_dep == GFC_DEP_EQUAL) 2244 break; 2245 2246 /* Exactly matching and forward overlapping ranges don't cause a 2247 dependency. */ 2248 if (fin_dep < GFC_DEP_BACKWARD) 2249 return 0; 2250 2251 /* Keep checking. We only have a dependency if 2252 subsequent references also overlap. */ 2253 break; 2254 2255 default: 2256 gcc_unreachable (); 2257 } 2258 lref = lref->next; 2259 rref = rref->next; 2260 } 2261 2262 /* If we haven't seen any array refs then something went wrong. */ 2263 gcc_assert (fin_dep != GFC_DEP_ERROR); 2264 2265 /* Assume the worst if we nest to different depths. */ 2266 if (lref || rref) 2267 return 1; 2268 2269 return fin_dep == GFC_DEP_OVERLAP; 2270 } 2271