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