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