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 /* Prevent NULL pointer dereference while recursively analyzing invalid 1295 expressions. */ 1296 if (expr2 == NULL) 1297 return 0; 1298 1299 switch (expr2->expr_type) 1300 { 1301 case EXPR_OP: 1302 n = gfc_check_dependency (expr1, expr2->value.op.op1, identical); 1303 if (n) 1304 return n; 1305 if (expr2->value.op.op2) 1306 return gfc_check_dependency (expr1, expr2->value.op.op2, identical); 1307 return 0; 1308 1309 case EXPR_VARIABLE: 1310 /* The interesting cases are when the symbols don't match. */ 1311 if (expr1->symtree->n.sym != expr2->symtree->n.sym) 1312 { 1313 symbol_attribute attr1, attr2; 1314 gfc_typespec *ts1 = &expr1->symtree->n.sym->ts; 1315 gfc_typespec *ts2 = &expr2->symtree->n.sym->ts; 1316 1317 /* Return 1 if expr1 and expr2 are equivalenced arrays. */ 1318 if (gfc_are_equivalenced_arrays (expr1, expr2)) 1319 return 1; 1320 1321 /* Symbols can only alias if they have the same type. */ 1322 if (ts1->type != BT_UNKNOWN && ts2->type != BT_UNKNOWN 1323 && ts1->type != BT_DERIVED && ts2->type != BT_DERIVED) 1324 { 1325 if (ts1->type != ts2->type || ts1->kind != ts2->kind) 1326 return 0; 1327 } 1328 1329 /* We have to also include target-target as ptr%comp is not a 1330 pointer but it still alias with "dt%comp" for "ptr => dt". As 1331 subcomponents and array access to pointers retains the target 1332 attribute, that's sufficient. */ 1333 attr1 = gfc_expr_attr (expr1); 1334 attr2 = gfc_expr_attr (expr2); 1335 if ((attr1.pointer || attr1.target) && (attr2.pointer || attr2.target)) 1336 { 1337 if (check_data_pointer_types (expr1, expr2) 1338 && check_data_pointer_types (expr2, expr1)) 1339 return 0; 1340 1341 return 1; 1342 } 1343 else 1344 { 1345 gfc_symbol *sym1 = expr1->symtree->n.sym; 1346 gfc_symbol *sym2 = expr2->symtree->n.sym; 1347 if (sym1->attr.target && sym2->attr.target 1348 && ((sym1->attr.dummy && !sym1->attr.contiguous 1349 && (!sym1->attr.dimension 1350 || sym2->as->type == AS_ASSUMED_SHAPE)) 1351 || (sym2->attr.dummy && !sym2->attr.contiguous 1352 && (!sym2->attr.dimension 1353 || sym2->as->type == AS_ASSUMED_SHAPE)))) 1354 return 1; 1355 } 1356 1357 /* Otherwise distinct symbols have no dependencies. */ 1358 return 0; 1359 } 1360 1361 /* Identical and disjoint ranges return 0, 1362 overlapping ranges return 1. */ 1363 if (expr1->ref && expr2->ref) 1364 return gfc_dep_resolver (expr1->ref, expr2->ref, NULL, identical); 1365 1366 return 1; 1367 1368 case EXPR_FUNCTION: 1369 if (gfc_get_noncopying_intrinsic_argument (expr2) != NULL) 1370 identical = 1; 1371 1372 /* Remember possible differences between elemental and 1373 transformational functions. All functions inside a FORALL 1374 will be pure. */ 1375 for (actual = expr2->value.function.actual; 1376 actual; actual = actual->next) 1377 { 1378 if (!actual->expr) 1379 continue; 1380 n = gfc_check_dependency (expr1, actual->expr, identical); 1381 if (n) 1382 return n; 1383 } 1384 return 0; 1385 1386 case EXPR_CONSTANT: 1387 case EXPR_NULL: 1388 return 0; 1389 1390 case EXPR_ARRAY: 1391 /* Loop through the array constructor's elements. */ 1392 for (c = gfc_constructor_first (expr2->value.constructor); 1393 c; c = gfc_constructor_next (c)) 1394 { 1395 /* If this is an iterator, assume the worst. */ 1396 if (c->iterator) 1397 return 1; 1398 /* Avoid recursion in the common case. */ 1399 if (c->expr->expr_type == EXPR_CONSTANT) 1400 continue; 1401 if (gfc_check_dependency (expr1, c->expr, 1)) 1402 return 1; 1403 } 1404 return 0; 1405 1406 default: 1407 return 1; 1408 } 1409 } 1410 1411 1412 /* Determines overlapping for two array sections. */ 1413 1414 static gfc_dependency 1415 check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) 1416 { 1417 gfc_expr *l_start; 1418 gfc_expr *l_end; 1419 gfc_expr *l_stride; 1420 gfc_expr *l_lower; 1421 gfc_expr *l_upper; 1422 int l_dir; 1423 1424 gfc_expr *r_start; 1425 gfc_expr *r_end; 1426 gfc_expr *r_stride; 1427 gfc_expr *r_lower; 1428 gfc_expr *r_upper; 1429 gfc_expr *one_expr; 1430 int r_dir; 1431 int stride_comparison; 1432 int start_comparison; 1433 mpz_t tmp; 1434 1435 /* If they are the same range, return without more ado. */ 1436 if (is_same_range (l_ar, r_ar, n)) 1437 return GFC_DEP_EQUAL; 1438 1439 l_start = l_ar->start[n]; 1440 l_end = l_ar->end[n]; 1441 l_stride = l_ar->stride[n]; 1442 1443 r_start = r_ar->start[n]; 1444 r_end = r_ar->end[n]; 1445 r_stride = r_ar->stride[n]; 1446 1447 /* If l_start is NULL take it from array specifier. */ 1448 if (l_start == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) 1449 l_start = l_ar->as->lower[n]; 1450 /* If l_end is NULL take it from array specifier. */ 1451 if (l_end == NULL && IS_ARRAY_EXPLICIT (l_ar->as)) 1452 l_end = l_ar->as->upper[n]; 1453 1454 /* If r_start is NULL take it from array specifier. */ 1455 if (r_start == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) 1456 r_start = r_ar->as->lower[n]; 1457 /* If r_end is NULL take it from array specifier. */ 1458 if (r_end == NULL && IS_ARRAY_EXPLICIT (r_ar->as)) 1459 r_end = r_ar->as->upper[n]; 1460 1461 /* Determine whether the l_stride is positive or negative. */ 1462 if (!l_stride) 1463 l_dir = 1; 1464 else if (l_stride->expr_type == EXPR_CONSTANT 1465 && l_stride->ts.type == BT_INTEGER) 1466 l_dir = mpz_sgn (l_stride->value.integer); 1467 else if (l_start && l_end) 1468 l_dir = gfc_dep_compare_expr (l_end, l_start); 1469 else 1470 l_dir = -2; 1471 1472 /* Determine whether the r_stride is positive or negative. */ 1473 if (!r_stride) 1474 r_dir = 1; 1475 else if (r_stride->expr_type == EXPR_CONSTANT 1476 && r_stride->ts.type == BT_INTEGER) 1477 r_dir = mpz_sgn (r_stride->value.integer); 1478 else if (r_start && r_end) 1479 r_dir = gfc_dep_compare_expr (r_end, r_start); 1480 else 1481 r_dir = -2; 1482 1483 /* The strides should never be zero. */ 1484 if (l_dir == 0 || r_dir == 0) 1485 return GFC_DEP_OVERLAP; 1486 1487 /* Determine the relationship between the strides. Set stride_comparison to 1488 -2 if the dependency cannot be determined 1489 -1 if l_stride < r_stride 1490 0 if l_stride == r_stride 1491 1 if l_stride > r_stride 1492 as determined by gfc_dep_compare_expr. */ 1493 1494 one_expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1495 1496 stride_comparison = gfc_dep_compare_expr (l_stride ? l_stride : one_expr, 1497 r_stride ? r_stride : one_expr); 1498 1499 if (l_start && r_start) 1500 start_comparison = gfc_dep_compare_expr (l_start, r_start); 1501 else 1502 start_comparison = -2; 1503 1504 gfc_free_expr (one_expr); 1505 1506 /* Determine LHS upper and lower bounds. */ 1507 if (l_dir == 1) 1508 { 1509 l_lower = l_start; 1510 l_upper = l_end; 1511 } 1512 else if (l_dir == -1) 1513 { 1514 l_lower = l_end; 1515 l_upper = l_start; 1516 } 1517 else 1518 { 1519 l_lower = NULL; 1520 l_upper = NULL; 1521 } 1522 1523 /* Determine RHS upper and lower bounds. */ 1524 if (r_dir == 1) 1525 { 1526 r_lower = r_start; 1527 r_upper = r_end; 1528 } 1529 else if (r_dir == -1) 1530 { 1531 r_lower = r_end; 1532 r_upper = r_start; 1533 } 1534 else 1535 { 1536 r_lower = NULL; 1537 r_upper = NULL; 1538 } 1539 1540 /* Check whether the ranges are disjoint. */ 1541 if (l_upper && r_lower && gfc_dep_compare_expr (l_upper, r_lower) == -1) 1542 return GFC_DEP_NODEP; 1543 if (r_upper && l_lower && gfc_dep_compare_expr (r_upper, l_lower) == -1) 1544 return GFC_DEP_NODEP; 1545 1546 /* Handle cases like x:y:1 vs. x:z:-1 as GFC_DEP_EQUAL. */ 1547 if (l_start && r_start && gfc_dep_compare_expr (l_start, r_start) == 0) 1548 { 1549 if (l_dir == 1 && r_dir == -1) 1550 return GFC_DEP_EQUAL; 1551 if (l_dir == -1 && r_dir == 1) 1552 return GFC_DEP_EQUAL; 1553 } 1554 1555 /* Handle cases like x:y:1 vs. z:y:-1 as GFC_DEP_EQUAL. */ 1556 if (l_end && r_end && gfc_dep_compare_expr (l_end, r_end) == 0) 1557 { 1558 if (l_dir == 1 && r_dir == -1) 1559 return GFC_DEP_EQUAL; 1560 if (l_dir == -1 && r_dir == 1) 1561 return GFC_DEP_EQUAL; 1562 } 1563 1564 /* Handle cases like x:y:2 vs. x+1:z:4 as GFC_DEP_NODEP. 1565 There is no dependency if the remainder of 1566 (l_start - r_start) / gcd(l_stride, r_stride) is 1567 nonzero. 1568 TODO: 1569 - Cases like a(1:4:2) = a(2:3) are still not handled. 1570 */ 1571 1572 #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ 1573 && (a)->ts.type == BT_INTEGER) 1574 1575 if (IS_CONSTANT_INTEGER (l_stride) && IS_CONSTANT_INTEGER (r_stride) 1576 && gfc_dep_difference (l_start, r_start, &tmp)) 1577 { 1578 mpz_t gcd; 1579 int result; 1580 1581 mpz_init (gcd); 1582 mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); 1583 1584 mpz_fdiv_r (tmp, tmp, gcd); 1585 result = mpz_cmp_si (tmp, 0L); 1586 1587 mpz_clear (gcd); 1588 mpz_clear (tmp); 1589 1590 if (result != 0) 1591 return GFC_DEP_NODEP; 1592 } 1593 1594 #undef IS_CONSTANT_INTEGER 1595 1596 /* Check for forward dependencies x:y vs. x+1:z and x:y:z vs. x:y:z+1. */ 1597 1598 if (l_dir == 1 && r_dir == 1 && 1599 (start_comparison == 0 || start_comparison == -1) 1600 && (stride_comparison == 0 || stride_comparison == -1)) 1601 return GFC_DEP_FORWARD; 1602 1603 /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and 1604 x:y:-1 vs. x:y:-2. */ 1605 if (l_dir == -1 && r_dir == -1 && 1606 (start_comparison == 0 || start_comparison == 1) 1607 && (stride_comparison == 0 || stride_comparison == 1)) 1608 return GFC_DEP_FORWARD; 1609 1610 if (stride_comparison == 0 || stride_comparison == -1) 1611 { 1612 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) 1613 { 1614 1615 /* Check for a(low:y:s) vs. a(z:x:s) or 1616 a(low:y:s) vs. a(z:x:s+1) where a has a lower bound 1617 of low, which is always at least a forward dependence. */ 1618 1619 if (r_dir == 1 1620 && gfc_dep_compare_expr (l_start, l_ar->as->lower[n]) == 0) 1621 return GFC_DEP_FORWARD; 1622 } 1623 } 1624 1625 if (stride_comparison == 0 || stride_comparison == 1) 1626 { 1627 if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) 1628 { 1629 1630 /* Check for a(high:y:-s) vs. a(z:x:-s) or 1631 a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound 1632 of high, which is always at least a forward dependence. */ 1633 1634 if (r_dir == -1 1635 && gfc_dep_compare_expr (l_start, l_ar->as->upper[n]) == 0) 1636 return GFC_DEP_FORWARD; 1637 } 1638 } 1639 1640 1641 if (stride_comparison == 0) 1642 { 1643 /* From here, check for backwards dependencies. */ 1644 /* x+1:y vs. x:z. */ 1645 if (l_dir == 1 && r_dir == 1 && start_comparison == 1) 1646 return GFC_DEP_BACKWARD; 1647 1648 /* x-1:y:-1 vs. x:z:-1. */ 1649 if (l_dir == -1 && r_dir == -1 && start_comparison == -1) 1650 return GFC_DEP_BACKWARD; 1651 } 1652 1653 return GFC_DEP_OVERLAP; 1654 } 1655 1656 1657 /* Determines overlapping for a single element and a section. */ 1658 1659 static gfc_dependency 1660 gfc_check_element_vs_section( gfc_ref *lref, gfc_ref *rref, int n) 1661 { 1662 gfc_array_ref *ref; 1663 gfc_expr *elem; 1664 gfc_expr *start; 1665 gfc_expr *end; 1666 gfc_expr *stride; 1667 int s; 1668 1669 elem = lref->u.ar.start[n]; 1670 if (!elem) 1671 return GFC_DEP_OVERLAP; 1672 1673 ref = &rref->u.ar; 1674 start = ref->start[n] ; 1675 end = ref->end[n] ; 1676 stride = ref->stride[n]; 1677 1678 if (!start && IS_ARRAY_EXPLICIT (ref->as)) 1679 start = ref->as->lower[n]; 1680 if (!end && IS_ARRAY_EXPLICIT (ref->as)) 1681 end = ref->as->upper[n]; 1682 1683 /* Determine whether the stride is positive or negative. */ 1684 if (!stride) 1685 s = 1; 1686 else if (stride->expr_type == EXPR_CONSTANT 1687 && stride->ts.type == BT_INTEGER) 1688 s = mpz_sgn (stride->value.integer); 1689 else 1690 s = -2; 1691 1692 /* Stride should never be zero. */ 1693 if (s == 0) 1694 return GFC_DEP_OVERLAP; 1695 1696 /* Positive strides. */ 1697 if (s == 1) 1698 { 1699 /* Check for elem < lower. */ 1700 if (start && gfc_dep_compare_expr (elem, start) == -1) 1701 return GFC_DEP_NODEP; 1702 /* Check for elem > upper. */ 1703 if (end && gfc_dep_compare_expr (elem, end) == 1) 1704 return GFC_DEP_NODEP; 1705 1706 if (start && end) 1707 { 1708 s = gfc_dep_compare_expr (start, end); 1709 /* Check for an empty range. */ 1710 if (s == 1) 1711 return GFC_DEP_NODEP; 1712 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) 1713 return GFC_DEP_EQUAL; 1714 } 1715 } 1716 /* Negative strides. */ 1717 else if (s == -1) 1718 { 1719 /* Check for elem > upper. */ 1720 if (end && gfc_dep_compare_expr (elem, start) == 1) 1721 return GFC_DEP_NODEP; 1722 /* Check for elem < lower. */ 1723 if (start && gfc_dep_compare_expr (elem, end) == -1) 1724 return GFC_DEP_NODEP; 1725 1726 if (start && end) 1727 { 1728 s = gfc_dep_compare_expr (start, end); 1729 /* Check for an empty range. */ 1730 if (s == -1) 1731 return GFC_DEP_NODEP; 1732 if (s == 0 && gfc_dep_compare_expr (elem, start) == 0) 1733 return GFC_DEP_EQUAL; 1734 } 1735 } 1736 /* Unknown strides. */ 1737 else 1738 { 1739 if (!start || !end) 1740 return GFC_DEP_OVERLAP; 1741 s = gfc_dep_compare_expr (start, end); 1742 if (s <= -2) 1743 return GFC_DEP_OVERLAP; 1744 /* Assume positive stride. */ 1745 if (s == -1) 1746 { 1747 /* Check for elem < lower. */ 1748 if (gfc_dep_compare_expr (elem, start) == -1) 1749 return GFC_DEP_NODEP; 1750 /* Check for elem > upper. */ 1751 if (gfc_dep_compare_expr (elem, end) == 1) 1752 return GFC_DEP_NODEP; 1753 } 1754 /* Assume negative stride. */ 1755 else if (s == 1) 1756 { 1757 /* Check for elem > upper. */ 1758 if (gfc_dep_compare_expr (elem, start) == 1) 1759 return GFC_DEP_NODEP; 1760 /* Check for elem < lower. */ 1761 if (gfc_dep_compare_expr (elem, end) == -1) 1762 return GFC_DEP_NODEP; 1763 } 1764 /* Equal bounds. */ 1765 else if (s == 0) 1766 { 1767 s = gfc_dep_compare_expr (elem, start); 1768 if (s == 0) 1769 return GFC_DEP_EQUAL; 1770 if (s == 1 || s == -1) 1771 return GFC_DEP_NODEP; 1772 } 1773 } 1774 1775 return GFC_DEP_OVERLAP; 1776 } 1777 1778 1779 /* Traverse expr, checking all EXPR_VARIABLE symbols for their 1780 forall_index attribute. Return true if any variable may be 1781 being used as a FORALL index. Its safe to pessimistically 1782 return true, and assume a dependency. */ 1783 1784 static bool 1785 contains_forall_index_p (gfc_expr *expr) 1786 { 1787 gfc_actual_arglist *arg; 1788 gfc_constructor *c; 1789 gfc_ref *ref; 1790 int i; 1791 1792 if (!expr) 1793 return false; 1794 1795 switch (expr->expr_type) 1796 { 1797 case EXPR_VARIABLE: 1798 if (expr->symtree->n.sym->forall_index) 1799 return true; 1800 break; 1801 1802 case EXPR_OP: 1803 if (contains_forall_index_p (expr->value.op.op1) 1804 || contains_forall_index_p (expr->value.op.op2)) 1805 return true; 1806 break; 1807 1808 case EXPR_FUNCTION: 1809 for (arg = expr->value.function.actual; arg; arg = arg->next) 1810 if (contains_forall_index_p (arg->expr)) 1811 return true; 1812 break; 1813 1814 case EXPR_CONSTANT: 1815 case EXPR_NULL: 1816 case EXPR_SUBSTRING: 1817 break; 1818 1819 case EXPR_STRUCTURE: 1820 case EXPR_ARRAY: 1821 for (c = gfc_constructor_first (expr->value.constructor); 1822 c; gfc_constructor_next (c)) 1823 if (contains_forall_index_p (c->expr)) 1824 return true; 1825 break; 1826 1827 default: 1828 gcc_unreachable (); 1829 } 1830 1831 for (ref = expr->ref; ref; ref = ref->next) 1832 switch (ref->type) 1833 { 1834 case REF_ARRAY: 1835 for (i = 0; i < ref->u.ar.dimen; i++) 1836 if (contains_forall_index_p (ref->u.ar.start[i]) 1837 || contains_forall_index_p (ref->u.ar.end[i]) 1838 || contains_forall_index_p (ref->u.ar.stride[i])) 1839 return true; 1840 break; 1841 1842 case REF_COMPONENT: 1843 break; 1844 1845 case REF_SUBSTRING: 1846 if (contains_forall_index_p (ref->u.ss.start) 1847 || contains_forall_index_p (ref->u.ss.end)) 1848 return true; 1849 break; 1850 1851 default: 1852 gcc_unreachable (); 1853 } 1854 1855 return false; 1856 } 1857 1858 /* Determines overlapping for two single element array references. */ 1859 1860 static gfc_dependency 1861 gfc_check_element_vs_element (gfc_ref *lref, gfc_ref *rref, int n) 1862 { 1863 gfc_array_ref l_ar; 1864 gfc_array_ref r_ar; 1865 gfc_expr *l_start; 1866 gfc_expr *r_start; 1867 int i; 1868 1869 l_ar = lref->u.ar; 1870 r_ar = rref->u.ar; 1871 l_start = l_ar.start[n] ; 1872 r_start = r_ar.start[n] ; 1873 i = gfc_dep_compare_expr (r_start, l_start); 1874 if (i == 0) 1875 return GFC_DEP_EQUAL; 1876 1877 /* Treat two scalar variables as potentially equal. This allows 1878 us to prove that a(i,:) and a(j,:) have no dependency. See 1879 Gerald Roth, "Evaluation of Array Syntax Dependence Analysis", 1880 Proceedings of the International Conference on Parallel and 1881 Distributed Processing Techniques and Applications (PDPTA2001), 1882 Las Vegas, Nevada, June 2001. */ 1883 /* However, we need to be careful when either scalar expression 1884 contains a FORALL index, as these can potentially change value 1885 during the scalarization/traversal of this array reference. */ 1886 if (contains_forall_index_p (r_start) || contains_forall_index_p (l_start)) 1887 return GFC_DEP_OVERLAP; 1888 1889 if (i > -2) 1890 return GFC_DEP_NODEP; 1891 1892 return GFC_DEP_EQUAL; 1893 } 1894 1895 /* Callback function for checking if an expression depends on a 1896 dummy variable which is any other than INTENT(IN). */ 1897 1898 static int 1899 callback_dummy_intent_not_in (gfc_expr **ep, 1900 int *walk_subtrees ATTRIBUTE_UNUSED, 1901 void *data ATTRIBUTE_UNUSED) 1902 { 1903 gfc_expr *e = *ep; 1904 1905 if (e->expr_type == EXPR_VARIABLE && e->symtree 1906 && e->symtree->n.sym->attr.dummy) 1907 return e->symtree->n.sym->attr.intent != INTENT_IN; 1908 else 1909 return 0; 1910 } 1911 1912 /* Auxiliary function to check if subexpressions have dummy variables which 1913 are not intent(in). 1914 */ 1915 1916 static bool 1917 dummy_intent_not_in (gfc_expr **ep) 1918 { 1919 return gfc_expr_walker (ep, callback_dummy_intent_not_in, NULL); 1920 } 1921 1922 /* Determine if an array ref, usually an array section specifies the 1923 entire array. In addition, if the second, pointer argument is 1924 provided, the function will return true if the reference is 1925 contiguous; eg. (:, 1) gives true but (1,:) gives false. 1926 If one of the bounds depends on a dummy variable which is 1927 not INTENT(IN), also return false, because the user may 1928 have changed the variable. */ 1929 1930 bool 1931 gfc_full_array_ref_p (gfc_ref *ref, bool *contiguous) 1932 { 1933 int i; 1934 int n; 1935 bool lbound_OK = true; 1936 bool ubound_OK = true; 1937 1938 if (contiguous) 1939 *contiguous = false; 1940 1941 if (ref->type != REF_ARRAY) 1942 return false; 1943 1944 if (ref->u.ar.type == AR_FULL) 1945 { 1946 if (contiguous) 1947 *contiguous = true; 1948 return true; 1949 } 1950 1951 if (ref->u.ar.type != AR_SECTION) 1952 return false; 1953 if (ref->next) 1954 return false; 1955 1956 for (i = 0; i < ref->u.ar.dimen; i++) 1957 { 1958 /* If we have a single element in the reference, for the reference 1959 to be full, we need to ascertain that the array has a single 1960 element in this dimension and that we actually reference the 1961 correct element. */ 1962 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) 1963 { 1964 /* This is unconditionally a contiguous reference if all the 1965 remaining dimensions are elements. */ 1966 if (contiguous) 1967 { 1968 *contiguous = true; 1969 for (n = i + 1; n < ref->u.ar.dimen; n++) 1970 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 1971 *contiguous = false; 1972 } 1973 1974 if (!ref->u.ar.as 1975 || !ref->u.ar.as->lower[i] 1976 || !ref->u.ar.as->upper[i] 1977 || gfc_dep_compare_expr (ref->u.ar.as->lower[i], 1978 ref->u.ar.as->upper[i]) 1979 || !ref->u.ar.start[i] 1980 || gfc_dep_compare_expr (ref->u.ar.start[i], 1981 ref->u.ar.as->lower[i])) 1982 return false; 1983 else 1984 continue; 1985 } 1986 1987 /* Check the lower bound. */ 1988 if (ref->u.ar.start[i] 1989 && (!ref->u.ar.as 1990 || !ref->u.ar.as->lower[i] 1991 || gfc_dep_compare_expr (ref->u.ar.start[i], 1992 ref->u.ar.as->lower[i]) 1993 || dummy_intent_not_in (&ref->u.ar.start[i]))) 1994 lbound_OK = false; 1995 /* Check the upper bound. */ 1996 if (ref->u.ar.end[i] 1997 && (!ref->u.ar.as 1998 || !ref->u.ar.as->upper[i] 1999 || gfc_dep_compare_expr (ref->u.ar.end[i], 2000 ref->u.ar.as->upper[i]) 2001 || dummy_intent_not_in (&ref->u.ar.end[i]))) 2002 ubound_OK = false; 2003 /* Check the stride. */ 2004 if (ref->u.ar.stride[i] 2005 && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) 2006 return false; 2007 2008 /* This is unconditionally a contiguous reference as long as all 2009 the subsequent dimensions are elements. */ 2010 if (contiguous) 2011 { 2012 *contiguous = true; 2013 for (n = i + 1; n < ref->u.ar.dimen; n++) 2014 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 2015 *contiguous = false; 2016 } 2017 2018 if (!lbound_OK || !ubound_OK) 2019 return false; 2020 } 2021 return true; 2022 } 2023 2024 2025 /* Determine if a full array is the same as an array section with one 2026 variable limit. For this to be so, the strides must both be unity 2027 and one of either start == lower or end == upper must be true. */ 2028 2029 static bool 2030 ref_same_as_full_array (gfc_ref *full_ref, gfc_ref *ref) 2031 { 2032 int i; 2033 bool upper_or_lower; 2034 2035 if (full_ref->type != REF_ARRAY) 2036 return false; 2037 if (full_ref->u.ar.type != AR_FULL) 2038 return false; 2039 if (ref->type != REF_ARRAY) 2040 return false; 2041 if (ref->u.ar.type == AR_FULL) 2042 return true; 2043 if (ref->u.ar.type != AR_SECTION) 2044 return false; 2045 2046 for (i = 0; i < ref->u.ar.dimen; i++) 2047 { 2048 /* If we have a single element in the reference, we need to check 2049 that the array has a single element and that we actually reference 2050 the correct element. */ 2051 if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT) 2052 { 2053 if (!full_ref->u.ar.as 2054 || !full_ref->u.ar.as->lower[i] 2055 || !full_ref->u.ar.as->upper[i] 2056 || gfc_dep_compare_expr (full_ref->u.ar.as->lower[i], 2057 full_ref->u.ar.as->upper[i]) 2058 || !ref->u.ar.start[i] 2059 || gfc_dep_compare_expr (ref->u.ar.start[i], 2060 full_ref->u.ar.as->lower[i])) 2061 return false; 2062 } 2063 2064 /* Check the strides. */ 2065 if (full_ref->u.ar.stride[i] && !gfc_expr_is_one (full_ref->u.ar.stride[i], 0)) 2066 return false; 2067 if (ref->u.ar.stride[i] && !gfc_expr_is_one (ref->u.ar.stride[i], 0)) 2068 return false; 2069 2070 upper_or_lower = false; 2071 /* Check the lower bound. */ 2072 if (ref->u.ar.start[i] 2073 && (ref->u.ar.as 2074 && full_ref->u.ar.as->lower[i] 2075 && gfc_dep_compare_expr (ref->u.ar.start[i], 2076 full_ref->u.ar.as->lower[i]) == 0)) 2077 upper_or_lower = true; 2078 /* Check the upper bound. */ 2079 if (ref->u.ar.end[i] 2080 && (ref->u.ar.as 2081 && full_ref->u.ar.as->upper[i] 2082 && gfc_dep_compare_expr (ref->u.ar.end[i], 2083 full_ref->u.ar.as->upper[i]) == 0)) 2084 upper_or_lower = true; 2085 if (!upper_or_lower) 2086 return false; 2087 } 2088 return true; 2089 } 2090 2091 2092 /* Finds if two array references are overlapping or not. 2093 Return value 2094 2 : array references are overlapping but reversal of one or 2095 more dimensions will clear the dependency. 2096 1 : array references are overlapping, or identical is true and 2097 there is some kind of overlap. 2098 0 : array references are identical or not overlapping. */ 2099 2100 int 2101 gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse, 2102 bool identical) 2103 { 2104 int n; 2105 int m; 2106 gfc_dependency fin_dep; 2107 gfc_dependency this_dep; 2108 bool same_component = false; 2109 2110 this_dep = GFC_DEP_ERROR; 2111 fin_dep = GFC_DEP_ERROR; 2112 /* Dependencies due to pointers should already have been identified. 2113 We only need to check for overlapping array references. */ 2114 2115 while (lref && rref) 2116 { 2117 /* The refs might come in mixed, one with a _data component and one 2118 without. Look at their next reference in order to avoid an 2119 ICE. */ 2120 2121 if (lref && lref->type == REF_COMPONENT && lref->u.c.component 2122 && strcmp (lref->u.c.component->name, "_data") == 0) 2123 lref = lref->next; 2124 2125 if (rref && rref->type == REF_COMPONENT && rref->u.c.component 2126 && strcmp (rref->u.c.component->name, "_data") == 0) 2127 rref = rref->next; 2128 2129 /* We're resolving from the same base symbol, so both refs should be 2130 the same type. We traverse the reference chain until we find ranges 2131 that are not equal. */ 2132 gcc_assert (lref->type == rref->type); 2133 switch (lref->type) 2134 { 2135 case REF_COMPONENT: 2136 /* The two ranges can't overlap if they are from different 2137 components. */ 2138 if (lref->u.c.component != rref->u.c.component) 2139 return 0; 2140 2141 same_component = true; 2142 break; 2143 2144 case REF_SUBSTRING: 2145 /* Substring overlaps are handled by the string assignment code 2146 if there is not an underlying dependency. */ 2147 return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; 2148 2149 case REF_ARRAY: 2150 2151 /* For now, treat all coarrays as dangerous. */ 2152 if (lref->u.ar.codimen || rref->u.ar.codimen) 2153 return 1; 2154 2155 if (ref_same_as_full_array (lref, rref)) 2156 return identical; 2157 2158 if (ref_same_as_full_array (rref, lref)) 2159 return identical; 2160 2161 if (lref->u.ar.dimen != rref->u.ar.dimen) 2162 { 2163 if (lref->u.ar.type == AR_FULL) 2164 fin_dep = gfc_full_array_ref_p (rref, NULL) ? GFC_DEP_EQUAL 2165 : GFC_DEP_OVERLAP; 2166 else if (rref->u.ar.type == AR_FULL) 2167 fin_dep = gfc_full_array_ref_p (lref, NULL) ? GFC_DEP_EQUAL 2168 : GFC_DEP_OVERLAP; 2169 else 2170 return 1; 2171 break; 2172 } 2173 2174 /* Index for the reverse array. */ 2175 m = -1; 2176 for (n = 0; n < lref->u.ar.dimen; n++) 2177 { 2178 /* Handle dependency when either of array reference is vector 2179 subscript. There is no dependency if the vector indices 2180 are equal or if indices are known to be different in a 2181 different dimension. */ 2182 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR 2183 || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) 2184 { 2185 if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR 2186 && rref->u.ar.dimen_type[n] == DIMEN_VECTOR 2187 && gfc_dep_compare_expr (lref->u.ar.start[n], 2188 rref->u.ar.start[n]) == 0) 2189 this_dep = GFC_DEP_EQUAL; 2190 else 2191 this_dep = GFC_DEP_OVERLAP; 2192 2193 goto update_fin_dep; 2194 } 2195 2196 if (lref->u.ar.dimen_type[n] == DIMEN_RANGE 2197 && rref->u.ar.dimen_type[n] == DIMEN_RANGE) 2198 this_dep = check_section_vs_section (&lref->u.ar, 2199 &rref->u.ar, n); 2200 else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2201 && rref->u.ar.dimen_type[n] == DIMEN_RANGE) 2202 this_dep = gfc_check_element_vs_section (lref, rref, n); 2203 else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2204 && lref->u.ar.dimen_type[n] == DIMEN_RANGE) 2205 this_dep = gfc_check_element_vs_section (rref, lref, n); 2206 else 2207 { 2208 gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT 2209 && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); 2210 this_dep = gfc_check_element_vs_element (rref, lref, n); 2211 if (identical && this_dep == GFC_DEP_EQUAL) 2212 this_dep = GFC_DEP_OVERLAP; 2213 } 2214 2215 /* If any dimension doesn't overlap, we have no dependency. */ 2216 if (this_dep == GFC_DEP_NODEP) 2217 return 0; 2218 2219 /* Now deal with the loop reversal logic: This only works on 2220 ranges and is activated by setting 2221 reverse[n] == GFC_ENABLE_REVERSE 2222 The ability to reverse or not is set by previous conditions 2223 in this dimension. If reversal is not activated, the 2224 value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ 2225 2226 /* Get the indexing right for the scalarizing loop. If this 2227 is an element, there is no corresponding loop. */ 2228 if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 2229 m++; 2230 2231 if (rref->u.ar.dimen_type[n] == DIMEN_RANGE 2232 && lref->u.ar.dimen_type[n] == DIMEN_RANGE) 2233 { 2234 if (reverse) 2235 { 2236 /* Reverse if backward dependence and not inhibited. */ 2237 if (reverse[m] == GFC_ENABLE_REVERSE 2238 && this_dep == GFC_DEP_BACKWARD) 2239 reverse[m] = GFC_REVERSE_SET; 2240 2241 /* Forward if forward dependence and not inhibited. */ 2242 if (reverse[m] == GFC_ENABLE_REVERSE 2243 && this_dep == GFC_DEP_FORWARD) 2244 reverse[m] = GFC_FORWARD_SET; 2245 2246 /* Flag up overlap if dependence not compatible with 2247 the overall state of the expression. */ 2248 if (reverse[m] == GFC_REVERSE_SET 2249 && this_dep == GFC_DEP_FORWARD) 2250 { 2251 reverse[m] = GFC_INHIBIT_REVERSE; 2252 this_dep = GFC_DEP_OVERLAP; 2253 } 2254 else if (reverse[m] == GFC_FORWARD_SET 2255 && this_dep == GFC_DEP_BACKWARD) 2256 { 2257 reverse[m] = GFC_INHIBIT_REVERSE; 2258 this_dep = GFC_DEP_OVERLAP; 2259 } 2260 } 2261 2262 /* If no intention of reversing or reversing is explicitly 2263 inhibited, convert backward dependence to overlap. */ 2264 if ((!reverse && this_dep == GFC_DEP_BACKWARD) 2265 || (reverse && reverse[m] == GFC_INHIBIT_REVERSE)) 2266 this_dep = GFC_DEP_OVERLAP; 2267 } 2268 2269 /* Overlap codes are in order of priority. We only need to 2270 know the worst one.*/ 2271 2272 update_fin_dep: 2273 if (identical && this_dep == GFC_DEP_EQUAL) 2274 this_dep = GFC_DEP_OVERLAP; 2275 2276 if (this_dep > fin_dep) 2277 fin_dep = this_dep; 2278 } 2279 2280 /* If this is an equal element, we have to keep going until we find 2281 the "real" array reference. */ 2282 if (lref->u.ar.type == AR_ELEMENT 2283 && rref->u.ar.type == AR_ELEMENT 2284 && fin_dep == GFC_DEP_EQUAL) 2285 break; 2286 2287 /* Exactly matching and forward overlapping ranges don't cause a 2288 dependency. */ 2289 if (fin_dep < GFC_DEP_BACKWARD && !identical) 2290 return 0; 2291 2292 /* Keep checking. We only have a dependency if 2293 subsequent references also overlap. */ 2294 break; 2295 2296 case REF_INQUIRY: 2297 if (lref->u.i != rref->u.i) 2298 return 0; 2299 2300 break; 2301 2302 default: 2303 gcc_unreachable (); 2304 } 2305 lref = lref->next; 2306 rref = rref->next; 2307 } 2308 2309 /* Assume the worst if we nest to different depths. */ 2310 if (lref || rref) 2311 return 1; 2312 2313 /* This can result from concatenation of assumed length string components. */ 2314 if (same_component && fin_dep == GFC_DEP_ERROR) 2315 return 1; 2316 2317 /* If we haven't seen any array refs then something went wrong. */ 2318 gcc_assert (fin_dep != GFC_DEP_ERROR); 2319 2320 if (identical && fin_dep != GFC_DEP_NODEP) 2321 return 1; 2322 2323 return fin_dep == GFC_DEP_OVERLAP; 2324 } 2325