1 /* Pass manager for Fortran front end. 2 Copyright (C) 2010-2020 Free Software Foundation, Inc. 3 Contributed by Thomas König. 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 #include "config.h" 22 #include "system.h" 23 #include "coretypes.h" 24 #include "options.h" 25 #include "gfortran.h" 26 #include "dependency.h" 27 #include "constructor.h" 28 #include "intrinsic.h" 29 30 /* Forward declarations. */ 31 32 static void strip_function_call (gfc_expr *); 33 static void optimize_namespace (gfc_namespace *); 34 static void optimize_assignment (gfc_code *); 35 static bool optimize_op (gfc_expr *); 36 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); 37 static bool optimize_trim (gfc_expr *); 38 static bool optimize_lexical_comparison (gfc_expr *); 39 static void optimize_minmaxloc (gfc_expr **); 40 static bool is_empty_string (gfc_expr *e); 41 static void doloop_warn (gfc_namespace *); 42 static int do_intent (gfc_expr **); 43 static int do_subscript (gfc_expr **); 44 static void optimize_reduction (gfc_namespace *); 45 static int callback_reduction (gfc_expr **, int *, void *); 46 static void realloc_strings (gfc_namespace *); 47 static gfc_expr *create_var (gfc_expr *, const char *vname=NULL); 48 static int matmul_to_var_expr (gfc_expr **, int *, void *); 49 static int matmul_to_var_code (gfc_code **, int *, void *); 50 static int inline_matmul_assign (gfc_code **, int *, void *); 51 static gfc_code * create_do_loop (gfc_expr *, gfc_expr *, gfc_expr *, 52 locus *, gfc_namespace *, 53 char *vname=NULL); 54 static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, 55 bool *); 56 static int call_external_blas (gfc_code **, int *, void *); 57 static int matmul_temp_args (gfc_code **, int *,void *data); 58 static int index_interchange (gfc_code **, int*, void *); 59 static bool is_fe_temp (gfc_expr *e); 60 61 #ifdef CHECKING_P 62 static void check_locus (gfc_namespace *); 63 #endif 64 65 /* How deep we are inside an argument list. */ 66 67 static int count_arglist; 68 69 /* Vector of gfc_expr ** we operate on. */ 70 71 static vec<gfc_expr **> expr_array; 72 73 /* Pointer to the gfc_code we currently work on - to be able to insert 74 a block before the statement. */ 75 76 static gfc_code **current_code; 77 78 /* Pointer to the block to be inserted, and the statement we are 79 changing within the block. */ 80 81 static gfc_code *inserted_block, **changed_statement; 82 83 /* The namespace we are currently dealing with. */ 84 85 static gfc_namespace *current_ns; 86 87 /* If we are within any forall loop. */ 88 89 static int forall_level; 90 91 /* Keep track of whether we are within an OMP workshare. */ 92 93 static bool in_omp_workshare; 94 95 /* Keep track of whether we are within an OMP atomic. */ 96 97 static bool in_omp_atomic; 98 99 /* Keep track of whether we are within a WHERE statement. */ 100 101 static bool in_where; 102 103 /* Keep track of iterators for array constructors. */ 104 105 static int iterator_level; 106 107 /* Keep track of DO loop levels. */ 108 109 typedef struct { 110 gfc_code *c; 111 int branch_level; 112 bool seen_goto; 113 } do_t; 114 115 static vec<do_t> doloop_list; 116 static int doloop_level; 117 118 /* Keep track of if and select case levels. */ 119 120 static int if_level; 121 static int select_level; 122 123 /* Vector of gfc_expr * to keep track of DO loops. */ 124 125 struct my_struct *evec; 126 127 /* Keep track of association lists. */ 128 129 static bool in_assoc_list; 130 131 /* Counter for temporary variables. */ 132 133 static int var_num = 1; 134 135 /* What sort of matrix we are dealing with when inlining MATMUL. */ 136 137 enum matrix_case { none=0, A2B2, A2B1, A1B2, A2B2T, A2TB2, A2TB2T }; 138 139 /* Keep track of the number of expressions we have inserted so far 140 using create_var. */ 141 142 int n_vars; 143 144 /* Entry point - run all passes for a namespace. */ 145 146 void 147 gfc_run_passes (gfc_namespace *ns) 148 { 149 150 /* Warn about dubious DO loops where the index might 151 change. */ 152 153 doloop_level = 0; 154 if_level = 0; 155 select_level = 0; 156 doloop_warn (ns); 157 doloop_list.release (); 158 int w, e; 159 160 #ifdef CHECKING_P 161 check_locus (ns); 162 #endif 163 164 gfc_get_errors (&w, &e); 165 if (e > 0) 166 return; 167 168 if (flag_frontend_optimize || flag_frontend_loop_interchange) 169 optimize_namespace (ns); 170 171 if (flag_frontend_optimize) 172 { 173 optimize_reduction (ns); 174 if (flag_dump_fortran_optimized) 175 gfc_dump_parse_tree (ns, stdout); 176 177 expr_array.release (); 178 } 179 180 if (flag_realloc_lhs) 181 realloc_strings (ns); 182 } 183 184 #ifdef CHECKING_P 185 186 /* Callback function: Warn if there is no location information in a 187 statement. */ 188 189 static int 190 check_locus_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 191 void *data ATTRIBUTE_UNUSED) 192 { 193 current_code = c; 194 if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL))) 195 gfc_warning_internal (0, "Inconsistent internal state: " 196 "No location in statement"); 197 198 return 0; 199 } 200 201 202 /* Callback function: Warn if there is no location information in an 203 expression. */ 204 205 static int 206 check_locus_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 207 void *data ATTRIBUTE_UNUSED) 208 { 209 210 if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL))) 211 gfc_warning_internal (0, "Inconsistent internal state: " 212 "No location in expression near %L", 213 &((*current_code)->loc)); 214 return 0; 215 } 216 217 /* Run check for missing location information. */ 218 219 static void 220 check_locus (gfc_namespace *ns) 221 { 222 gfc_code_walker (&ns->code, check_locus_code, check_locus_expr, NULL); 223 224 for (ns = ns->contained; ns; ns = ns->sibling) 225 { 226 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 227 check_locus (ns); 228 } 229 } 230 231 #endif 232 233 /* Callback for each gfc_code node invoked from check_realloc_strings. 234 For an allocatable LHS string which also appears as a variable on 235 the RHS, replace 236 237 a = a(x:y) 238 239 with 240 241 tmp = a(x:y) 242 a = tmp 243 */ 244 245 static int 246 realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 247 void *data ATTRIBUTE_UNUSED) 248 { 249 gfc_expr *expr1, *expr2; 250 gfc_code *co = *c; 251 gfc_expr *n; 252 gfc_ref *ref; 253 bool found_substr; 254 255 if (co->op != EXEC_ASSIGN) 256 return 0; 257 258 expr1 = co->expr1; 259 if (expr1->ts.type != BT_CHARACTER 260 || !gfc_expr_attr(expr1).allocatable 261 || !expr1->ts.deferred) 262 return 0; 263 264 if (is_fe_temp (expr1)) 265 return 0; 266 267 expr2 = gfc_discard_nops (co->expr2); 268 269 if (expr2->expr_type == EXPR_VARIABLE) 270 { 271 found_substr = false; 272 for (ref = expr2->ref; ref; ref = ref->next) 273 { 274 if (ref->type == REF_SUBSTRING) 275 { 276 found_substr = true; 277 break; 278 } 279 } 280 if (!found_substr) 281 return 0; 282 } 283 else if (expr2->expr_type != EXPR_ARRAY 284 && (expr2->expr_type != EXPR_OP 285 || expr2->value.op.op != INTRINSIC_CONCAT)) 286 return 0; 287 288 if (!gfc_check_dependency (expr1, expr2, true)) 289 return 0; 290 291 /* gfc_check_dependency doesn't always pick up identical expressions. 292 However, eliminating the above sends the compiler into an infinite 293 loop on valid expressions. Without this check, the gimplifier emits 294 an ICE for a = a, where a is deferred character length. */ 295 if (!gfc_dep_compare_expr (expr1, expr2)) 296 return 0; 297 298 current_code = c; 299 inserted_block = NULL; 300 changed_statement = NULL; 301 n = create_var (expr2, "realloc_string"); 302 co->expr2 = n; 303 return 0; 304 } 305 306 /* Callback for each gfc_code node invoked through gfc_code_walker 307 from optimize_namespace. */ 308 309 static int 310 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 311 void *data ATTRIBUTE_UNUSED) 312 { 313 314 gfc_exec_op op; 315 316 op = (*c)->op; 317 318 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL 319 || op == EXEC_CALL_PPC) 320 count_arglist = 1; 321 else 322 count_arglist = 0; 323 324 current_code = c; 325 inserted_block = NULL; 326 changed_statement = NULL; 327 328 if (op == EXEC_ASSIGN) 329 optimize_assignment (*c); 330 return 0; 331 } 332 333 /* Callback for each gfc_expr node invoked through gfc_code_walker 334 from optimize_namespace. */ 335 336 static int 337 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 338 void *data ATTRIBUTE_UNUSED) 339 { 340 bool function_expr; 341 342 if ((*e)->expr_type == EXPR_FUNCTION) 343 { 344 count_arglist ++; 345 function_expr = true; 346 } 347 else 348 function_expr = false; 349 350 if (optimize_trim (*e)) 351 gfc_simplify_expr (*e, 0); 352 353 if (optimize_lexical_comparison (*e)) 354 gfc_simplify_expr (*e, 0); 355 356 if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) 357 gfc_simplify_expr (*e, 0); 358 359 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) 360 switch ((*e)->value.function.isym->id) 361 { 362 case GFC_ISYM_MINLOC: 363 case GFC_ISYM_MAXLOC: 364 optimize_minmaxloc (e); 365 break; 366 default: 367 break; 368 } 369 370 if (function_expr) 371 count_arglist --; 372 373 return 0; 374 } 375 376 /* Auxiliary function to handle the arguments to reduction intrnisics. If the 377 function is a scalar, just copy it; otherwise returns the new element, the 378 old one can be freed. */ 379 380 static gfc_expr * 381 copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) 382 { 383 gfc_expr *fcn, *e = c->expr; 384 385 fcn = gfc_copy_expr (e); 386 if (c->iterator) 387 { 388 gfc_constructor_base newbase; 389 gfc_expr *new_expr; 390 gfc_constructor *new_c; 391 392 newbase = NULL; 393 new_expr = gfc_get_expr (); 394 new_expr->expr_type = EXPR_ARRAY; 395 new_expr->ts = e->ts; 396 new_expr->where = e->where; 397 new_expr->rank = 1; 398 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where)); 399 new_c->iterator = c->iterator; 400 new_expr->value.constructor = newbase; 401 c->iterator = NULL; 402 403 fcn = new_expr; 404 } 405 406 if (fcn->rank != 0) 407 { 408 gfc_isym_id id = fn->value.function.isym->id; 409 410 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) 411 fcn = gfc_build_intrinsic_call (current_ns, id, 412 fn->value.function.isym->name, 413 fn->where, 3, fcn, NULL, NULL); 414 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) 415 fcn = gfc_build_intrinsic_call (current_ns, id, 416 fn->value.function.isym->name, 417 fn->where, 2, fcn, NULL); 418 else 419 gfc_internal_error ("Illegal id in copy_walk_reduction_arg"); 420 421 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; 422 } 423 424 return fcn; 425 } 426 427 /* Callback function for optimzation of reductions to scalars. Transform ANY 428 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT 429 correspondingly. Handly only the simple cases without MASK and DIM. */ 430 431 static int 432 callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 433 void *data ATTRIBUTE_UNUSED) 434 { 435 gfc_expr *fn, *arg; 436 gfc_intrinsic_op op; 437 gfc_isym_id id; 438 gfc_actual_arglist *a; 439 gfc_actual_arglist *dim; 440 gfc_constructor *c; 441 gfc_expr *res, *new_expr; 442 gfc_actual_arglist *mask; 443 444 fn = *e; 445 446 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION 447 || fn->value.function.isym == NULL) 448 return 0; 449 450 id = fn->value.function.isym->id; 451 452 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT 453 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL) 454 return 0; 455 456 a = fn->value.function.actual; 457 458 /* Don't handle MASK or DIM. */ 459 460 dim = a->next; 461 462 if (dim->expr != NULL) 463 return 0; 464 465 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) 466 { 467 mask = dim->next; 468 if ( mask->expr != NULL) 469 return 0; 470 } 471 472 arg = a->expr; 473 474 if (arg->expr_type != EXPR_ARRAY) 475 return 0; 476 477 switch (id) 478 { 479 case GFC_ISYM_SUM: 480 op = INTRINSIC_PLUS; 481 break; 482 483 case GFC_ISYM_PRODUCT: 484 op = INTRINSIC_TIMES; 485 break; 486 487 case GFC_ISYM_ANY: 488 op = INTRINSIC_OR; 489 break; 490 491 case GFC_ISYM_ALL: 492 op = INTRINSIC_AND; 493 break; 494 495 default: 496 return 0; 497 } 498 499 c = gfc_constructor_first (arg->value.constructor); 500 501 /* Don't do any simplififcation if we have 502 - no element in the constructor or 503 - only have a single element in the array which contains an 504 iterator. */ 505 506 if (c == NULL) 507 return 0; 508 509 res = copy_walk_reduction_arg (c, fn); 510 511 c = gfc_constructor_next (c); 512 while (c) 513 { 514 new_expr = gfc_get_expr (); 515 new_expr->ts = fn->ts; 516 new_expr->expr_type = EXPR_OP; 517 new_expr->rank = fn->rank; 518 new_expr->where = fn->where; 519 new_expr->value.op.op = op; 520 new_expr->value.op.op1 = res; 521 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn); 522 res = new_expr; 523 c = gfc_constructor_next (c); 524 } 525 526 gfc_simplify_expr (res, 0); 527 *e = res; 528 gfc_free_expr (fn); 529 530 return 0; 531 } 532 533 /* Callback function for common function elimination, called from cfe_expr_0. 534 Put all eligible function expressions into expr_array. */ 535 536 static int 537 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 538 void *data ATTRIBUTE_UNUSED) 539 { 540 541 if ((*e)->expr_type != EXPR_FUNCTION) 542 return 0; 543 544 /* We don't do character functions with unknown charlens. */ 545 if ((*e)->ts.type == BT_CHARACTER 546 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL 547 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 548 return 0; 549 550 /* We don't do function elimination within FORALL statements, it can 551 lead to wrong-code in certain circumstances. */ 552 553 if (forall_level > 0) 554 return 0; 555 556 /* Function elimination inside an iterator could lead to functions which 557 depend on iterator variables being moved outside. FIXME: We should check 558 if the functions do indeed depend on the iterator variable. */ 559 560 if (iterator_level > 0) 561 return 0; 562 563 /* If we don't know the shape at compile time, we create an allocatable 564 temporary variable to hold the intermediate result, but only if 565 allocation on assignment is active. */ 566 567 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) 568 return 0; 569 570 /* Skip the test for pure functions if -faggressive-function-elimination 571 is specified. */ 572 if ((*e)->value.function.esym) 573 { 574 /* Don't create an array temporary for elemental functions. */ 575 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) 576 return 0; 577 578 /* Only eliminate potentially impure functions if the 579 user specifically requested it. */ 580 if (!flag_aggressive_function_elimination 581 && !(*e)->value.function.esym->attr.pure 582 && !(*e)->value.function.esym->attr.implicit_pure) 583 return 0; 584 } 585 586 if ((*e)->value.function.isym) 587 { 588 /* Conversions are handled on the fly by the middle end, 589 transpose during trans-* stages and TRANSFER by the middle end. */ 590 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION 591 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER 592 || gfc_inline_intrinsic_function_p (*e)) 593 return 0; 594 595 /* Don't create an array temporary for elemental functions, 596 as this would be wasteful of memory. 597 FIXME: Create a scalar temporary during scalarization. */ 598 if ((*e)->value.function.isym->elemental && (*e)->rank > 0) 599 return 0; 600 601 if (!(*e)->value.function.isym->pure) 602 return 0; 603 } 604 605 expr_array.safe_push (e); 606 return 0; 607 } 608 609 /* Auxiliary function to check if an expression is a temporary created by 610 create var. */ 611 612 static bool 613 is_fe_temp (gfc_expr *e) 614 { 615 if (e->expr_type != EXPR_VARIABLE) 616 return false; 617 618 return e->symtree->n.sym->attr.fe_temp; 619 } 620 621 /* Determine the length of a string, if it can be evaluated as a constant 622 expression. Return a newly allocated gfc_expr or NULL on failure. 623 If the user specified a substring which is potentially longer than 624 the string itself, the string will be padded with spaces, which 625 is harmless. */ 626 627 static gfc_expr * 628 constant_string_length (gfc_expr *e) 629 { 630 631 gfc_expr *length; 632 gfc_ref *ref; 633 gfc_expr *res; 634 mpz_t value; 635 636 if (e->ts.u.cl) 637 { 638 length = e->ts.u.cl->length; 639 if (length && length->expr_type == EXPR_CONSTANT) 640 return gfc_copy_expr(length); 641 } 642 643 /* See if there is a substring. If it has a constant length, return 644 that and NULL otherwise. */ 645 for (ref = e->ref; ref; ref = ref->next) 646 { 647 if (ref->type == REF_SUBSTRING) 648 { 649 if (gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value)) 650 { 651 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, 652 &e->where); 653 654 mpz_add_ui (res->value.integer, value, 1); 655 mpz_clear (value); 656 return res; 657 } 658 else 659 return NULL; 660 } 661 } 662 663 /* Return length of char symbol, if constant. */ 664 if (e->symtree && e->symtree->n.sym->ts.u.cl 665 && e->symtree->n.sym->ts.u.cl->length 666 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 667 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); 668 669 return NULL; 670 671 } 672 673 /* Insert a block at the current position unless it has already 674 been inserted; in this case use the one already there. */ 675 676 static gfc_namespace* 677 insert_block () 678 { 679 gfc_namespace *ns; 680 681 /* If the block hasn't already been created, do so. */ 682 if (inserted_block == NULL) 683 { 684 inserted_block = XCNEW (gfc_code); 685 inserted_block->op = EXEC_BLOCK; 686 inserted_block->loc = (*current_code)->loc; 687 ns = gfc_build_block_ns (current_ns); 688 inserted_block->ext.block.ns = ns; 689 inserted_block->ext.block.assoc = NULL; 690 691 ns->code = *current_code; 692 693 /* If the statement has a label, make sure it is transferred to 694 the newly created block. */ 695 696 if ((*current_code)->here) 697 { 698 inserted_block->here = (*current_code)->here; 699 (*current_code)->here = NULL; 700 } 701 702 inserted_block->next = (*current_code)->next; 703 changed_statement = &(inserted_block->ext.block.ns->code); 704 (*current_code)->next = NULL; 705 /* Insert the BLOCK at the right position. */ 706 *current_code = inserted_block; 707 ns->parent = current_ns; 708 } 709 else 710 ns = inserted_block->ext.block.ns; 711 712 return ns; 713 } 714 715 716 /* Insert a call to the intrinsic len. Use a different name for 717 the symbol tree so we don't run into trouble when the user has 718 renamed len for some reason. */ 719 720 static gfc_expr* 721 get_len_call (gfc_expr *str) 722 { 723 gfc_expr *fcn; 724 gfc_actual_arglist *actual_arglist; 725 726 fcn = gfc_get_expr (); 727 fcn->expr_type = EXPR_FUNCTION; 728 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN); 729 actual_arglist = gfc_get_actual_arglist (); 730 actual_arglist->expr = str; 731 732 fcn->value.function.actual = actual_arglist; 733 fcn->where = str->where; 734 fcn->ts.type = BT_INTEGER; 735 fcn->ts.kind = gfc_charlen_int_kind; 736 737 gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false); 738 fcn->symtree->n.sym->ts = fcn->ts; 739 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; 740 fcn->symtree->n.sym->attr.function = 1; 741 fcn->symtree->n.sym->attr.elemental = 1; 742 fcn->symtree->n.sym->attr.referenced = 1; 743 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; 744 gfc_commit_symbol (fcn->symtree->n.sym); 745 746 return fcn; 747 } 748 749 750 /* Returns a new expression (a variable) to be used in place of the old one, 751 with an optional assignment statement before the current statement to set 752 the value of the variable. Creates a new BLOCK for the statement if that 753 hasn't already been done and puts the statement, plus the newly created 754 variables, in that block. Special cases: If the expression is constant or 755 a temporary which has already been created, just copy it. */ 756 757 static gfc_expr* 758 create_var (gfc_expr * e, const char *vname) 759 { 760 char name[GFC_MAX_SYMBOL_LEN +1]; 761 gfc_symtree *symtree; 762 gfc_symbol *symbol; 763 gfc_expr *result; 764 gfc_code *n; 765 gfc_namespace *ns; 766 int i; 767 bool deferred; 768 769 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) 770 return gfc_copy_expr (e); 771 772 /* Creation of an array of unknown size requires realloc on assignment. 773 If that is not possible, just return NULL. */ 774 if (flag_realloc_lhs == 0 && e->rank > 0 && e->shape == NULL) 775 return NULL; 776 777 ns = insert_block (); 778 779 if (vname) 780 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname); 781 else 782 snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++); 783 784 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) 785 gcc_unreachable (); 786 787 symbol = symtree->n.sym; 788 symbol->ts = e->ts; 789 790 if (e->rank > 0) 791 { 792 symbol->as = gfc_get_array_spec (); 793 symbol->as->rank = e->rank; 794 795 if (e->shape == NULL) 796 { 797 /* We don't know the shape at compile time, so we use an 798 allocatable. */ 799 symbol->as->type = AS_DEFERRED; 800 symbol->attr.allocatable = 1; 801 } 802 else 803 { 804 symbol->as->type = AS_EXPLICIT; 805 /* Copy the shape. */ 806 for (i=0; i<e->rank; i++) 807 { 808 gfc_expr *p, *q; 809 810 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 811 &(e->where)); 812 mpz_set_si (p->value.integer, 1); 813 symbol->as->lower[i] = p; 814 815 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 816 &(e->where)); 817 mpz_set (q->value.integer, e->shape[i]); 818 symbol->as->upper[i] = q; 819 } 820 } 821 } 822 823 deferred = 0; 824 if (e->ts.type == BT_CHARACTER) 825 { 826 gfc_expr *length; 827 828 symbol->ts.u.cl = gfc_new_charlen (ns, NULL); 829 length = constant_string_length (e); 830 if (length) 831 symbol->ts.u.cl->length = length; 832 else if (e->expr_type == EXPR_VARIABLE 833 && e->symtree->n.sym->ts.type == BT_CHARACTER 834 && e->ts.u.cl->length) 835 symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e)); 836 else 837 { 838 symbol->attr.allocatable = 1; 839 symbol->ts.u.cl->length = NULL; 840 symbol->ts.deferred = 1; 841 deferred = 1; 842 } 843 } 844 845 symbol->attr.flavor = FL_VARIABLE; 846 symbol->attr.referenced = 1; 847 symbol->attr.dimension = e->rank > 0; 848 symbol->attr.fe_temp = 1; 849 gfc_commit_symbol (symbol); 850 851 result = gfc_get_expr (); 852 result->expr_type = EXPR_VARIABLE; 853 result->ts = symbol->ts; 854 result->ts.deferred = deferred; 855 result->rank = e->rank; 856 result->shape = gfc_copy_shape (e->shape, e->rank); 857 result->symtree = symtree; 858 result->where = e->where; 859 if (e->rank > 0) 860 { 861 result->ref = gfc_get_ref (); 862 result->ref->type = REF_ARRAY; 863 result->ref->u.ar.type = AR_FULL; 864 result->ref->u.ar.where = e->where; 865 result->ref->u.ar.dimen = e->rank; 866 result->ref->u.ar.as = symbol->ts.type == BT_CLASS 867 ? CLASS_DATA (symbol)->as : symbol->as; 868 if (warn_array_temporaries) 869 gfc_warning (OPT_Warray_temporaries, 870 "Creating array temporary at %L", &(e->where)); 871 } 872 873 /* Generate the new assignment. */ 874 n = XCNEW (gfc_code); 875 n->op = EXEC_ASSIGN; 876 n->loc = (*current_code)->loc; 877 n->next = *changed_statement; 878 n->expr1 = gfc_copy_expr (result); 879 n->expr2 = e; 880 *changed_statement = n; 881 n_vars ++; 882 883 return result; 884 } 885 886 /* Warn about function elimination. */ 887 888 static void 889 do_warn_function_elimination (gfc_expr *e) 890 { 891 const char *name; 892 if (e->expr_type == EXPR_FUNCTION 893 && !gfc_pure_function (e, &name) && !gfc_implicit_pure_function (e)) 894 { 895 if (name) 896 gfc_warning (OPT_Wfunction_elimination, 897 "Removing call to impure function %qs at %L", name, 898 &(e->where)); 899 else 900 gfc_warning (OPT_Wfunction_elimination, 901 "Removing call to impure function at %L", 902 &(e->where)); 903 } 904 } 905 906 907 /* Callback function for the code walker for doing common function 908 elimination. This builds up the list of functions in the expression 909 and goes through them to detect duplicates, which it then replaces 910 by variables. */ 911 912 static int 913 cfe_expr_0 (gfc_expr **e, int *walk_subtrees, 914 void *data ATTRIBUTE_UNUSED) 915 { 916 int i,j; 917 gfc_expr *newvar; 918 gfc_expr **ei, **ej; 919 920 /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */ 921 922 if (in_omp_workshare || in_omp_atomic || in_assoc_list) 923 { 924 *walk_subtrees = 0; 925 return 0; 926 } 927 928 expr_array.release (); 929 930 gfc_expr_walker (e, cfe_register_funcs, NULL); 931 932 /* Walk through all the functions. */ 933 934 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1) 935 { 936 /* Skip if the function has been replaced by a variable already. */ 937 if ((*ei)->expr_type == EXPR_VARIABLE) 938 continue; 939 940 newvar = NULL; 941 for (j=0; j<i; j++) 942 { 943 ej = expr_array[j]; 944 if (gfc_dep_compare_functions (*ei, *ej, true) == 0) 945 { 946 if (newvar == NULL) 947 newvar = create_var (*ei, "fcn"); 948 949 if (warn_function_elimination) 950 do_warn_function_elimination (*ej); 951 952 free (*ej); 953 *ej = gfc_copy_expr (newvar); 954 } 955 } 956 if (newvar) 957 *ei = newvar; 958 } 959 960 /* We did all the necessary walking in this function. */ 961 *walk_subtrees = 0; 962 return 0; 963 } 964 965 /* Callback function for common function elimination, called from 966 gfc_code_walker. This keeps track of the current code, in order 967 to insert statements as needed. */ 968 969 static int 970 cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) 971 { 972 current_code = c; 973 inserted_block = NULL; 974 changed_statement = NULL; 975 976 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs 977 and allocation on assigment are prohibited inside WHERE, and finally 978 masking an expression would lead to wrong-code when replacing 979 980 WHERE (a>0) 981 b = sum(foo(a) + foo(a)) 982 END WHERE 983 984 with 985 986 WHERE (a > 0) 987 tmp = foo(a) 988 b = sum(tmp + tmp) 989 END WHERE 990 */ 991 992 if ((*c)->op == EXEC_WHERE) 993 { 994 *walk_subtrees = 0; 995 return 0; 996 } 997 998 999 return 0; 1000 } 1001 1002 /* Dummy function for expression call back, for use when we 1003 really don't want to do any walking. */ 1004 1005 static int 1006 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees, 1007 void *data ATTRIBUTE_UNUSED) 1008 { 1009 *walk_subtrees = 0; 1010 return 0; 1011 } 1012 1013 /* Dummy function for code callback, for use when we really 1014 don't want to do anything. */ 1015 int 1016 gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED, 1017 int *walk_subtrees ATTRIBUTE_UNUSED, 1018 void *data ATTRIBUTE_UNUSED) 1019 { 1020 return 0; 1021 } 1022 1023 /* Code callback function for converting 1024 do while(a) 1025 end do 1026 into the equivalent 1027 do 1028 if (.not. a) exit 1029 end do 1030 This is because common function elimination would otherwise place the 1031 temporary variables outside the loop. */ 1032 1033 static int 1034 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 1035 void *data ATTRIBUTE_UNUSED) 1036 { 1037 gfc_code *co = *c; 1038 gfc_code *c_if1, *c_if2, *c_exit; 1039 gfc_code *loopblock; 1040 gfc_expr *e_not, *e_cond; 1041 1042 if (co->op != EXEC_DO_WHILE) 1043 return 0; 1044 1045 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT) 1046 return 0; 1047 1048 e_cond = co->expr1; 1049 1050 /* Generate the condition of the if statement, which is .not. the original 1051 statement. */ 1052 e_not = gfc_get_expr (); 1053 e_not->ts = e_cond->ts; 1054 e_not->where = e_cond->where; 1055 e_not->expr_type = EXPR_OP; 1056 e_not->value.op.op = INTRINSIC_NOT; 1057 e_not->value.op.op1 = e_cond; 1058 1059 /* Generate the EXIT statement. */ 1060 c_exit = XCNEW (gfc_code); 1061 c_exit->op = EXEC_EXIT; 1062 c_exit->ext.which_construct = co; 1063 c_exit->loc = co->loc; 1064 1065 /* Generate the IF statement. */ 1066 c_if2 = XCNEW (gfc_code); 1067 c_if2->op = EXEC_IF; 1068 c_if2->expr1 = e_not; 1069 c_if2->next = c_exit; 1070 c_if2->loc = co->loc; 1071 1072 /* ... plus the one to chain it to. */ 1073 c_if1 = XCNEW (gfc_code); 1074 c_if1->op = EXEC_IF; 1075 c_if1->block = c_if2; 1076 c_if1->loc = co->loc; 1077 1078 /* Make the DO WHILE loop into a DO block by replacing the condition 1079 with a true constant. */ 1080 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true); 1081 1082 /* Hang the generated if statement into the loop body. */ 1083 1084 loopblock = co->block->next; 1085 co->block->next = c_if1; 1086 c_if1->next = loopblock; 1087 1088 return 0; 1089 } 1090 1091 /* Code callback function for converting 1092 if (a) then 1093 ... 1094 else if (b) then 1095 end if 1096 1097 into 1098 if (a) then 1099 else 1100 if (b) then 1101 end if 1102 end if 1103 1104 because otherwise common function elimination would place the BLOCKs 1105 into the wrong place. */ 1106 1107 static int 1108 convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 1109 void *data ATTRIBUTE_UNUSED) 1110 { 1111 gfc_code *co = *c; 1112 gfc_code *c_if1, *c_if2, *else_stmt; 1113 1114 if (co->op != EXEC_IF) 1115 return 0; 1116 1117 /* This loop starts out with the first ELSE statement. */ 1118 else_stmt = co->block->block; 1119 1120 while (else_stmt != NULL) 1121 { 1122 gfc_code *next_else; 1123 1124 /* If there is no condition, we're done. */ 1125 if (else_stmt->expr1 == NULL) 1126 break; 1127 1128 next_else = else_stmt->block; 1129 1130 /* Generate the new IF statement. */ 1131 c_if2 = XCNEW (gfc_code); 1132 c_if2->op = EXEC_IF; 1133 c_if2->expr1 = else_stmt->expr1; 1134 c_if2->next = else_stmt->next; 1135 c_if2->loc = else_stmt->loc; 1136 c_if2->block = next_else; 1137 1138 /* ... plus the one to chain it to. */ 1139 c_if1 = XCNEW (gfc_code); 1140 c_if1->op = EXEC_IF; 1141 c_if1->block = c_if2; 1142 c_if1->loc = else_stmt->loc; 1143 1144 /* Insert the new IF after the ELSE. */ 1145 else_stmt->expr1 = NULL; 1146 else_stmt->next = c_if1; 1147 else_stmt->block = NULL; 1148 1149 else_stmt = next_else; 1150 } 1151 /* Don't walk subtrees. */ 1152 return 0; 1153 } 1154 1155 /* Callback function to var_in_expr - return true if expr1 and 1156 expr2 are identical variables. */ 1157 static int 1158 var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 1159 void *data) 1160 { 1161 gfc_expr *expr1 = (gfc_expr *) data; 1162 gfc_expr *expr2 = *e; 1163 1164 if (expr2->expr_type != EXPR_VARIABLE) 1165 return 0; 1166 1167 return expr1->symtree->n.sym == expr2->symtree->n.sym; 1168 } 1169 1170 /* Return true if expr1 is found in expr2. */ 1171 1172 static bool 1173 var_in_expr (gfc_expr *expr1, gfc_expr *expr2) 1174 { 1175 gcc_assert (expr1->expr_type == EXPR_VARIABLE); 1176 1177 return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1); 1178 } 1179 1180 struct do_stack 1181 { 1182 struct do_stack *prev; 1183 gfc_iterator *iter; 1184 gfc_code *code; 1185 } *stack_top; 1186 1187 /* Recursively traverse the block of a WRITE or READ statement, and maybe 1188 optimize by replacing do loops with their analog array slices. For 1189 example: 1190 1191 write (*,*) (a(i), i=1,4) 1192 1193 is replaced with 1194 1195 write (*,*) a(1:4:1) . */ 1196 1197 static bool 1198 traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev) 1199 { 1200 gfc_code *curr; 1201 gfc_expr *new_e, *expr, *start; 1202 gfc_ref *ref; 1203 struct do_stack ds_push; 1204 int i, future_rank = 0; 1205 gfc_iterator *iters[GFC_MAX_DIMENSIONS]; 1206 gfc_expr *e; 1207 1208 /* Find the first transfer/do statement. */ 1209 for (curr = code; curr; curr = curr->next) 1210 { 1211 if (curr->op == EXEC_DO || curr->op == EXEC_TRANSFER) 1212 break; 1213 } 1214 1215 /* Ensure it is the only transfer/do statement because cases like 1216 1217 write (*,*) (a(i), b(i), i=1,4) 1218 1219 cannot be optimized. */ 1220 1221 if (!curr || curr->next) 1222 return false; 1223 1224 if (curr->op == EXEC_DO) 1225 { 1226 if (curr->ext.iterator->var->ref) 1227 return false; 1228 ds_push.prev = stack_top; 1229 ds_push.iter = curr->ext.iterator; 1230 ds_push.code = curr; 1231 stack_top = &ds_push; 1232 if (traverse_io_block (curr->block->next, has_reached, prev)) 1233 { 1234 if (curr != stack_top->code && !*has_reached) 1235 { 1236 curr->block->next = NULL; 1237 gfc_free_statements (curr); 1238 } 1239 else 1240 *has_reached = true; 1241 return true; 1242 } 1243 return false; 1244 } 1245 1246 gcc_assert (curr->op == EXEC_TRANSFER); 1247 1248 e = curr->expr1; 1249 ref = e->ref; 1250 if (!ref || ref->type != REF_ARRAY || ref->u.ar.codimen != 0 || ref->next) 1251 return false; 1252 1253 /* Find the iterators belonging to each variable and check conditions. */ 1254 for (i = 0; i < ref->u.ar.dimen; i++) 1255 { 1256 if (!ref->u.ar.start[i] || ref->u.ar.start[i]->ref 1257 || ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) 1258 return false; 1259 1260 start = ref->u.ar.start[i]; 1261 gfc_simplify_expr (start, 0); 1262 switch (start->expr_type) 1263 { 1264 case EXPR_VARIABLE: 1265 1266 /* write (*,*) (a(i), i=a%b,1) not handled yet. */ 1267 if (start->ref) 1268 return false; 1269 1270 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */ 1271 if (!stack_top || !stack_top->iter 1272 || stack_top->iter->var->symtree != start->symtree) 1273 { 1274 /* Check for (a(i,i), i=1,3). */ 1275 int j; 1276 1277 for (j=0; j<i; j++) 1278 if (iters[j] && iters[j]->var->symtree == start->symtree) 1279 return false; 1280 1281 iters[i] = NULL; 1282 } 1283 else 1284 { 1285 iters[i] = stack_top->iter; 1286 stack_top = stack_top->prev; 1287 future_rank++; 1288 } 1289 break; 1290 case EXPR_CONSTANT: 1291 iters[i] = NULL; 1292 break; 1293 case EXPR_OP: 1294 switch (start->value.op.op) 1295 { 1296 case INTRINSIC_PLUS: 1297 case INTRINSIC_TIMES: 1298 if (start->value.op.op1->expr_type != EXPR_VARIABLE) 1299 std::swap (start->value.op.op1, start->value.op.op2); 1300 gcc_fallthrough (); 1301 case INTRINSIC_MINUS: 1302 if (start->value.op.op1->expr_type!= EXPR_VARIABLE 1303 || start->value.op.op2->expr_type != EXPR_CONSTANT 1304 || start->value.op.op1->ref) 1305 return false; 1306 if (!stack_top || !stack_top->iter 1307 || stack_top->iter->var->symtree 1308 != start->value.op.op1->symtree) 1309 return false; 1310 iters[i] = stack_top->iter; 1311 stack_top = stack_top->prev; 1312 break; 1313 default: 1314 return false; 1315 } 1316 future_rank++; 1317 break; 1318 default: 1319 return false; 1320 } 1321 } 1322 1323 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */ 1324 for (int i = 1; i < ref->u.ar.dimen; i++) 1325 { 1326 if (iters[i]) 1327 { 1328 gfc_expr *var = iters[i]->var; 1329 for (int j = i - 1; j < i; j++) 1330 { 1331 if (iters[j] 1332 && (var_in_expr (var, iters[j]->start) 1333 || var_in_expr (var, iters[j]->end) 1334 || var_in_expr (var, iters[j]->step))) 1335 return false; 1336 } 1337 } 1338 } 1339 1340 /* Create new expr. */ 1341 new_e = gfc_copy_expr (curr->expr1); 1342 new_e->expr_type = EXPR_VARIABLE; 1343 new_e->rank = future_rank; 1344 if (curr->expr1->shape) 1345 new_e->shape = gfc_get_shape (new_e->rank); 1346 1347 /* Assign new starts, ends and strides if necessary. */ 1348 for (i = 0; i < ref->u.ar.dimen; i++) 1349 { 1350 if (!iters[i]) 1351 continue; 1352 start = ref->u.ar.start[i]; 1353 switch (start->expr_type) 1354 { 1355 case EXPR_CONSTANT: 1356 gfc_internal_error ("bad expression"); 1357 break; 1358 case EXPR_VARIABLE: 1359 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; 1360 new_e->ref->u.ar.type = AR_SECTION; 1361 gfc_free_expr (new_e->ref->u.ar.start[i]); 1362 new_e->ref->u.ar.start[i] = gfc_copy_expr (iters[i]->start); 1363 new_e->ref->u.ar.end[i] = gfc_copy_expr (iters[i]->end); 1364 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); 1365 break; 1366 case EXPR_OP: 1367 new_e->ref->u.ar.dimen_type[i] = DIMEN_RANGE; 1368 new_e->ref->u.ar.type = AR_SECTION; 1369 gfc_free_expr (new_e->ref->u.ar.start[i]); 1370 expr = gfc_copy_expr (start); 1371 expr->value.op.op1 = gfc_copy_expr (iters[i]->start); 1372 new_e->ref->u.ar.start[i] = expr; 1373 gfc_simplify_expr (new_e->ref->u.ar.start[i], 0); 1374 expr = gfc_copy_expr (start); 1375 expr->value.op.op1 = gfc_copy_expr (iters[i]->end); 1376 new_e->ref->u.ar.end[i] = expr; 1377 gfc_simplify_expr (new_e->ref->u.ar.end[i], 0); 1378 switch (start->value.op.op) 1379 { 1380 case INTRINSIC_MINUS: 1381 case INTRINSIC_PLUS: 1382 new_e->ref->u.ar.stride[i] = gfc_copy_expr (iters[i]->step); 1383 break; 1384 case INTRINSIC_TIMES: 1385 expr = gfc_copy_expr (start); 1386 expr->value.op.op1 = gfc_copy_expr (iters[i]->step); 1387 new_e->ref->u.ar.stride[i] = expr; 1388 gfc_simplify_expr (new_e->ref->u.ar.stride[i], 0); 1389 break; 1390 default: 1391 gfc_internal_error ("bad op"); 1392 } 1393 break; 1394 default: 1395 gfc_internal_error ("bad expression"); 1396 } 1397 } 1398 curr->expr1 = new_e; 1399 1400 /* Insert modified statement. Check whether the statement needs to be 1401 inserted at the lowest level. */ 1402 if (!stack_top->iter) 1403 { 1404 if (prev) 1405 { 1406 curr->next = prev->next->next; 1407 prev->next = curr; 1408 } 1409 else 1410 { 1411 curr->next = stack_top->code->block->next->next->next; 1412 stack_top->code->block->next = curr; 1413 } 1414 } 1415 else 1416 stack_top->code->block->next = curr; 1417 return true; 1418 } 1419 1420 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it 1421 tries to optimize its block. */ 1422 1423 static int 1424 simplify_io_impl_do (gfc_code **code, int *walk_subtrees, 1425 void *data ATTRIBUTE_UNUSED) 1426 { 1427 gfc_code **curr, *prev = NULL; 1428 struct do_stack write, first; 1429 bool b = false; 1430 *walk_subtrees = 1; 1431 if (!(*code)->block 1432 || ((*code)->block->op != EXEC_WRITE 1433 && (*code)->block->op != EXEC_READ)) 1434 return 0; 1435 1436 *walk_subtrees = 0; 1437 write.prev = NULL; 1438 write.iter = NULL; 1439 write.code = *code; 1440 1441 for (curr = &(*code)->block; *curr; curr = &(*curr)->next) 1442 { 1443 if ((*curr)->op == EXEC_DO) 1444 { 1445 first.prev = &write; 1446 first.iter = (*curr)->ext.iterator; 1447 first.code = *curr; 1448 stack_top = &first; 1449 traverse_io_block ((*curr)->block->next, &b, prev); 1450 stack_top = NULL; 1451 } 1452 prev = *curr; 1453 } 1454 return 0; 1455 } 1456 1457 /* Optimize a namespace, including all contained namespaces. 1458 flag_frontend_optimize and flag_fronend_loop_interchange are 1459 handled separately. */ 1460 1461 static void 1462 optimize_namespace (gfc_namespace *ns) 1463 { 1464 gfc_namespace *saved_ns = gfc_current_ns; 1465 current_ns = ns; 1466 gfc_current_ns = ns; 1467 forall_level = 0; 1468 iterator_level = 0; 1469 in_assoc_list = false; 1470 in_omp_workshare = false; 1471 in_omp_atomic = false; 1472 1473 if (flag_frontend_optimize) 1474 { 1475 gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); 1476 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); 1477 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); 1478 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); 1479 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); 1480 if (flag_inline_matmul_limit != 0 || flag_external_blas) 1481 { 1482 bool found; 1483 do 1484 { 1485 found = false; 1486 gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, 1487 (void *) &found); 1488 } 1489 while (found); 1490 1491 gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, 1492 NULL); 1493 } 1494 1495 if (flag_external_blas) 1496 gfc_code_walker (&ns->code, call_external_blas, dummy_expr_callback, 1497 NULL); 1498 1499 if (flag_inline_matmul_limit != 0) 1500 gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, 1501 NULL); 1502 } 1503 1504 if (flag_frontend_loop_interchange) 1505 gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback, 1506 NULL); 1507 1508 /* BLOCKs are handled in the expression walker below. */ 1509 for (ns = ns->contained; ns; ns = ns->sibling) 1510 { 1511 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 1512 optimize_namespace (ns); 1513 } 1514 gfc_current_ns = saved_ns; 1515 } 1516 1517 /* Handle dependencies for allocatable strings which potentially redefine 1518 themselves in an assignment. */ 1519 1520 static void 1521 realloc_strings (gfc_namespace *ns) 1522 { 1523 current_ns = ns; 1524 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL); 1525 1526 for (ns = ns->contained; ns; ns = ns->sibling) 1527 { 1528 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 1529 realloc_strings (ns); 1530 } 1531 1532 } 1533 1534 static void 1535 optimize_reduction (gfc_namespace *ns) 1536 { 1537 current_ns = ns; 1538 gfc_code_walker (&ns->code, gfc_dummy_code_callback, 1539 callback_reduction, NULL); 1540 1541 /* BLOCKs are handled in the expression walker below. */ 1542 for (ns = ns->contained; ns; ns = ns->sibling) 1543 { 1544 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 1545 optimize_reduction (ns); 1546 } 1547 } 1548 1549 /* Replace code like 1550 a = matmul(b,c) + d 1551 with 1552 a = matmul(b,c) ; a = a + d 1553 where the array function is not elemental and not allocatable 1554 and does not depend on the left-hand side. 1555 */ 1556 1557 static bool 1558 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) 1559 { 1560 gfc_expr *e; 1561 1562 if (!*rhs) 1563 return false; 1564 1565 e = *rhs; 1566 if (e->expr_type == EXPR_OP) 1567 { 1568 switch (e->value.op.op) 1569 { 1570 /* Unary operators and exponentiation: Only look at a single 1571 operand. */ 1572 case INTRINSIC_NOT: 1573 case INTRINSIC_UPLUS: 1574 case INTRINSIC_UMINUS: 1575 case INTRINSIC_PARENTHESES: 1576 case INTRINSIC_POWER: 1577 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) 1578 return true; 1579 break; 1580 1581 case INTRINSIC_CONCAT: 1582 /* Do not do string concatenations. */ 1583 break; 1584 1585 default: 1586 /* Binary operators. */ 1587 if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) 1588 return true; 1589 1590 if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) 1591 return true; 1592 1593 break; 1594 } 1595 } 1596 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 1597 && ! (e->value.function.esym 1598 && (e->value.function.esym->attr.elemental 1599 || e->value.function.esym->attr.allocatable 1600 || e->value.function.esym->ts.type != c->expr1->ts.type 1601 || e->value.function.esym->ts.kind != c->expr1->ts.kind)) 1602 && ! (e->value.function.isym 1603 && (e->value.function.isym->elemental 1604 || e->ts.type != c->expr1->ts.type 1605 || e->ts.kind != c->expr1->ts.kind)) 1606 && ! gfc_inline_intrinsic_function_p (e)) 1607 { 1608 1609 gfc_code *n; 1610 gfc_expr *new_expr; 1611 1612 /* Insert a new assignment statement after the current one. */ 1613 n = XCNEW (gfc_code); 1614 n->op = EXEC_ASSIGN; 1615 n->loc = c->loc; 1616 n->next = c->next; 1617 c->next = n; 1618 1619 n->expr1 = gfc_copy_expr (c->expr1); 1620 n->expr2 = c->expr2; 1621 new_expr = gfc_copy_expr (c->expr1); 1622 c->expr2 = e; 1623 *rhs = new_expr; 1624 1625 return true; 1626 1627 } 1628 1629 /* Nothing to optimize. */ 1630 return false; 1631 } 1632 1633 /* Remove unneeded TRIMs at the end of expressions. */ 1634 1635 static bool 1636 remove_trim (gfc_expr *rhs) 1637 { 1638 bool ret; 1639 1640 ret = false; 1641 if (!rhs) 1642 return ret; 1643 1644 /* Check for a // b // trim(c). Looping is probably not 1645 necessary because the parser usually generates 1646 (// (// a b ) trim(c) ) , but better safe than sorry. */ 1647 1648 while (rhs->expr_type == EXPR_OP 1649 && rhs->value.op.op == INTRINSIC_CONCAT) 1650 rhs = rhs->value.op.op2; 1651 1652 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym 1653 && rhs->value.function.isym->id == GFC_ISYM_TRIM) 1654 { 1655 strip_function_call (rhs); 1656 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ 1657 remove_trim (rhs); 1658 ret = true; 1659 } 1660 1661 return ret; 1662 } 1663 1664 /* Optimizations for an assignment. */ 1665 1666 static void 1667 optimize_assignment (gfc_code * c) 1668 { 1669 gfc_expr *lhs, *rhs; 1670 1671 lhs = c->expr1; 1672 rhs = c->expr2; 1673 1674 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) 1675 { 1676 /* Optimize a = trim(b) to a = b. */ 1677 remove_trim (rhs); 1678 1679 /* Replace a = ' ' by a = '' to optimize away a memcpy. */ 1680 if (is_empty_string (rhs)) 1681 rhs->value.character.length = 0; 1682 } 1683 1684 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) 1685 optimize_binop_array_assignment (c, &rhs, false); 1686 } 1687 1688 1689 /* Remove an unneeded function call, modifying the expression. 1690 This replaces the function call with the value of its 1691 first argument. The rest of the argument list is freed. */ 1692 1693 static void 1694 strip_function_call (gfc_expr *e) 1695 { 1696 gfc_expr *e1; 1697 gfc_actual_arglist *a; 1698 1699 a = e->value.function.actual; 1700 1701 /* We should have at least one argument. */ 1702 gcc_assert (a->expr != NULL); 1703 1704 e1 = a->expr; 1705 1706 /* Free the remaining arglist, if any. */ 1707 if (a->next) 1708 gfc_free_actual_arglist (a->next); 1709 1710 /* Graft the argument expression onto the original function. */ 1711 *e = *e1; 1712 free (e1); 1713 1714 } 1715 1716 /* Optimization of lexical comparison functions. */ 1717 1718 static bool 1719 optimize_lexical_comparison (gfc_expr *e) 1720 { 1721 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) 1722 return false; 1723 1724 switch (e->value.function.isym->id) 1725 { 1726 case GFC_ISYM_LLE: 1727 return optimize_comparison (e, INTRINSIC_LE); 1728 1729 case GFC_ISYM_LGE: 1730 return optimize_comparison (e, INTRINSIC_GE); 1731 1732 case GFC_ISYM_LGT: 1733 return optimize_comparison (e, INTRINSIC_GT); 1734 1735 case GFC_ISYM_LLT: 1736 return optimize_comparison (e, INTRINSIC_LT); 1737 1738 default: 1739 break; 1740 } 1741 return false; 1742 } 1743 1744 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not 1745 do CHARACTER because of possible pessimization involving character 1746 lengths. */ 1747 1748 static bool 1749 combine_array_constructor (gfc_expr *e) 1750 { 1751 1752 gfc_expr *op1, *op2; 1753 gfc_expr *scalar; 1754 gfc_expr *new_expr; 1755 gfc_constructor *c, *new_c; 1756 gfc_constructor_base oldbase, newbase; 1757 bool scalar_first; 1758 int n_elem; 1759 bool all_const; 1760 1761 /* Array constructors have rank one. */ 1762 if (e->rank != 1) 1763 return false; 1764 1765 /* Don't try to combine association lists, this makes no sense 1766 and leads to an ICE. */ 1767 if (in_assoc_list) 1768 return false; 1769 1770 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ 1771 if (forall_level > 0) 1772 return false; 1773 1774 /* Inside an iterator, things can get hairy; we are likely to create 1775 an invalid temporary variable. */ 1776 if (iterator_level > 0) 1777 return false; 1778 1779 /* WHERE also doesn't work. */ 1780 if (in_where > 0) 1781 return false; 1782 1783 op1 = e->value.op.op1; 1784 op2 = e->value.op.op2; 1785 1786 if (!op1 || !op2) 1787 return false; 1788 1789 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0) 1790 scalar_first = false; 1791 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0) 1792 { 1793 scalar_first = true; 1794 op1 = e->value.op.op2; 1795 op2 = e->value.op.op1; 1796 } 1797 else 1798 return false; 1799 1800 if (op2->ts.type == BT_CHARACTER) 1801 return false; 1802 1803 /* This might be an expanded constructor with very many constant values. If 1804 we perform the operation here, we might end up with a long compile time 1805 and actually longer execution time, so a length bound is in order here. 1806 If the constructor constains something which is not a constant, it did 1807 not come from an expansion, so leave it alone. */ 1808 1809 #define CONSTR_LEN_MAX 4 1810 1811 oldbase = op1->value.constructor; 1812 1813 n_elem = 0; 1814 all_const = true; 1815 for (c = gfc_constructor_first (oldbase); c; c = gfc_constructor_next(c)) 1816 { 1817 if (c->expr->expr_type != EXPR_CONSTANT) 1818 { 1819 all_const = false; 1820 break; 1821 } 1822 n_elem += 1; 1823 } 1824 1825 if (all_const && n_elem > CONSTR_LEN_MAX) 1826 return false; 1827 1828 #undef CONSTR_LEN_MAX 1829 1830 newbase = NULL; 1831 e->expr_type = EXPR_ARRAY; 1832 1833 scalar = create_var (gfc_copy_expr (op2), "constr"); 1834 1835 for (c = gfc_constructor_first (oldbase); c; 1836 c = gfc_constructor_next (c)) 1837 { 1838 new_expr = gfc_get_expr (); 1839 new_expr->ts = e->ts; 1840 new_expr->expr_type = EXPR_OP; 1841 new_expr->rank = c->expr->rank; 1842 new_expr->where = c->expr->where; 1843 new_expr->value.op.op = e->value.op.op; 1844 1845 if (scalar_first) 1846 { 1847 new_expr->value.op.op1 = gfc_copy_expr (scalar); 1848 new_expr->value.op.op2 = gfc_copy_expr (c->expr); 1849 } 1850 else 1851 { 1852 new_expr->value.op.op1 = gfc_copy_expr (c->expr); 1853 new_expr->value.op.op2 = gfc_copy_expr (scalar); 1854 } 1855 1856 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where)); 1857 new_c->iterator = c->iterator; 1858 c->iterator = NULL; 1859 } 1860 1861 gfc_free_expr (op1); 1862 gfc_free_expr (op2); 1863 gfc_free_expr (scalar); 1864 1865 e->value.constructor = newbase; 1866 return true; 1867 } 1868 1869 /* Recursive optimization of operators. */ 1870 1871 static bool 1872 optimize_op (gfc_expr *e) 1873 { 1874 bool changed; 1875 1876 gfc_intrinsic_op op = e->value.op.op; 1877 1878 changed = false; 1879 1880 /* Only use new-style comparisons. */ 1881 switch(op) 1882 { 1883 case INTRINSIC_EQ_OS: 1884 op = INTRINSIC_EQ; 1885 break; 1886 1887 case INTRINSIC_GE_OS: 1888 op = INTRINSIC_GE; 1889 break; 1890 1891 case INTRINSIC_LE_OS: 1892 op = INTRINSIC_LE; 1893 break; 1894 1895 case INTRINSIC_NE_OS: 1896 op = INTRINSIC_NE; 1897 break; 1898 1899 case INTRINSIC_GT_OS: 1900 op = INTRINSIC_GT; 1901 break; 1902 1903 case INTRINSIC_LT_OS: 1904 op = INTRINSIC_LT; 1905 break; 1906 1907 default: 1908 break; 1909 } 1910 1911 switch (op) 1912 { 1913 case INTRINSIC_EQ: 1914 case INTRINSIC_GE: 1915 case INTRINSIC_LE: 1916 case INTRINSIC_NE: 1917 case INTRINSIC_GT: 1918 case INTRINSIC_LT: 1919 changed = optimize_comparison (e, op); 1920 1921 gcc_fallthrough (); 1922 /* Look at array constructors. */ 1923 case INTRINSIC_PLUS: 1924 case INTRINSIC_MINUS: 1925 case INTRINSIC_TIMES: 1926 case INTRINSIC_DIVIDE: 1927 return combine_array_constructor (e) || changed; 1928 1929 default: 1930 break; 1931 } 1932 1933 return false; 1934 } 1935 1936 1937 /* Return true if a constant string contains only blanks. */ 1938 1939 static bool 1940 is_empty_string (gfc_expr *e) 1941 { 1942 int i; 1943 1944 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) 1945 return false; 1946 1947 for (i=0; i < e->value.character.length; i++) 1948 { 1949 if (e->value.character.string[i] != ' ') 1950 return false; 1951 } 1952 1953 return true; 1954 } 1955 1956 1957 /* Insert a call to the intrinsic len_trim. Use a different name for 1958 the symbol tree so we don't run into trouble when the user has 1959 renamed len_trim for some reason. */ 1960 1961 static gfc_expr* 1962 get_len_trim_call (gfc_expr *str, int kind) 1963 { 1964 gfc_expr *fcn; 1965 gfc_actual_arglist *actual_arglist, *next; 1966 1967 fcn = gfc_get_expr (); 1968 fcn->expr_type = EXPR_FUNCTION; 1969 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); 1970 actual_arglist = gfc_get_actual_arglist (); 1971 actual_arglist->expr = str; 1972 next = gfc_get_actual_arglist (); 1973 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); 1974 actual_arglist->next = next; 1975 1976 fcn->value.function.actual = actual_arglist; 1977 fcn->where = str->where; 1978 fcn->ts.type = BT_INTEGER; 1979 fcn->ts.kind = gfc_charlen_int_kind; 1980 1981 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false); 1982 fcn->symtree->n.sym->ts = fcn->ts; 1983 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; 1984 fcn->symtree->n.sym->attr.function = 1; 1985 fcn->symtree->n.sym->attr.elemental = 1; 1986 fcn->symtree->n.sym->attr.referenced = 1; 1987 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; 1988 gfc_commit_symbol (fcn->symtree->n.sym); 1989 1990 return fcn; 1991 } 1992 1993 1994 /* Optimize expressions for equality. */ 1995 1996 static bool 1997 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) 1998 { 1999 gfc_expr *op1, *op2; 2000 bool change; 2001 int eq; 2002 bool result; 2003 gfc_actual_arglist *firstarg, *secondarg; 2004 2005 if (e->expr_type == EXPR_OP) 2006 { 2007 firstarg = NULL; 2008 secondarg = NULL; 2009 op1 = e->value.op.op1; 2010 op2 = e->value.op.op2; 2011 } 2012 else if (e->expr_type == EXPR_FUNCTION) 2013 { 2014 /* One of the lexical comparison functions. */ 2015 firstarg = e->value.function.actual; 2016 secondarg = firstarg->next; 2017 op1 = firstarg->expr; 2018 op2 = secondarg->expr; 2019 } 2020 else 2021 gcc_unreachable (); 2022 2023 /* Strip off unneeded TRIM calls from string comparisons. */ 2024 2025 change = remove_trim (op1); 2026 2027 if (remove_trim (op2)) 2028 change = true; 2029 2030 /* An expression of type EXPR_CONSTANT is only valid for scalars. */ 2031 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer 2032 handles them well). However, there are also cases that need a non-scalar 2033 argument. For example the any intrinsic. See PR 45380. */ 2034 if (e->rank > 0) 2035 return change; 2036 2037 /* Replace a == '' with len_trim(a) == 0 and a /= '' with 2038 len_trim(a) != 0 */ 2039 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 2040 && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) 2041 { 2042 bool empty_op1, empty_op2; 2043 empty_op1 = is_empty_string (op1); 2044 empty_op2 = is_empty_string (op2); 2045 2046 if (empty_op1 || empty_op2) 2047 { 2048 gfc_expr *fcn; 2049 gfc_expr *zero; 2050 gfc_expr *str; 2051 2052 /* This can only happen when an error for comparing 2053 characters of different kinds has already been issued. */ 2054 if (empty_op1 && empty_op2) 2055 return false; 2056 2057 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); 2058 str = empty_op1 ? op2 : op1; 2059 2060 fcn = get_len_trim_call (str, gfc_charlen_int_kind); 2061 2062 2063 if (empty_op1) 2064 gfc_free_expr (op1); 2065 else 2066 gfc_free_expr (op2); 2067 2068 op1 = fcn; 2069 op2 = zero; 2070 e->value.op.op1 = fcn; 2071 e->value.op.op2 = zero; 2072 } 2073 } 2074 2075 2076 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ 2077 2078 if (flag_finite_math_only 2079 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL 2080 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) 2081 { 2082 eq = gfc_dep_compare_expr (op1, op2); 2083 if (eq <= -2) 2084 { 2085 /* Replace A // B < A // C with B < C, and A // B < C // B 2086 with A < C. */ 2087 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 2088 && op1->expr_type == EXPR_OP 2089 && op1->value.op.op == INTRINSIC_CONCAT 2090 && op2->expr_type == EXPR_OP 2091 && op2->value.op.op == INTRINSIC_CONCAT) 2092 { 2093 gfc_expr *op1_left = op1->value.op.op1; 2094 gfc_expr *op2_left = op2->value.op.op1; 2095 gfc_expr *op1_right = op1->value.op.op2; 2096 gfc_expr *op2_right = op2->value.op.op2; 2097 2098 if (gfc_dep_compare_expr (op1_left, op2_left) == 0) 2099 { 2100 /* Watch out for 'A ' // x vs. 'A' // x. */ 2101 2102 if (op1_left->expr_type == EXPR_CONSTANT 2103 && op2_left->expr_type == EXPR_CONSTANT 2104 && op1_left->value.character.length 2105 != op2_left->value.character.length) 2106 return change; 2107 else 2108 { 2109 free (op1_left); 2110 free (op2_left); 2111 if (firstarg) 2112 { 2113 firstarg->expr = op1_right; 2114 secondarg->expr = op2_right; 2115 } 2116 else 2117 { 2118 e->value.op.op1 = op1_right; 2119 e->value.op.op2 = op2_right; 2120 } 2121 optimize_comparison (e, op); 2122 return true; 2123 } 2124 } 2125 if (gfc_dep_compare_expr (op1_right, op2_right) == 0) 2126 { 2127 free (op1_right); 2128 free (op2_right); 2129 if (firstarg) 2130 { 2131 firstarg->expr = op1_left; 2132 secondarg->expr = op2_left; 2133 } 2134 else 2135 { 2136 e->value.op.op1 = op1_left; 2137 e->value.op.op2 = op2_left; 2138 } 2139 2140 optimize_comparison (e, op); 2141 return true; 2142 } 2143 } 2144 } 2145 else 2146 { 2147 /* eq can only be -1, 0 or 1 at this point. */ 2148 switch (op) 2149 { 2150 case INTRINSIC_EQ: 2151 result = eq == 0; 2152 break; 2153 2154 case INTRINSIC_GE: 2155 result = eq >= 0; 2156 break; 2157 2158 case INTRINSIC_LE: 2159 result = eq <= 0; 2160 break; 2161 2162 case INTRINSIC_NE: 2163 result = eq != 0; 2164 break; 2165 2166 case INTRINSIC_GT: 2167 result = eq > 0; 2168 break; 2169 2170 case INTRINSIC_LT: 2171 result = eq < 0; 2172 break; 2173 2174 default: 2175 gfc_internal_error ("illegal OP in optimize_comparison"); 2176 break; 2177 } 2178 2179 /* Replace the expression by a constant expression. The typespec 2180 and where remains the way it is. */ 2181 free (op1); 2182 free (op2); 2183 e->expr_type = EXPR_CONSTANT; 2184 e->value.logical = result; 2185 return true; 2186 } 2187 } 2188 2189 return change; 2190 } 2191 2192 /* Optimize a trim function by replacing it with an equivalent substring 2193 involving a call to len_trim. This only works for expressions where 2194 variables are trimmed. Return true if anything was modified. */ 2195 2196 static bool 2197 optimize_trim (gfc_expr *e) 2198 { 2199 gfc_expr *a; 2200 gfc_ref *ref; 2201 gfc_expr *fcn; 2202 gfc_ref **rr = NULL; 2203 2204 /* Don't do this optimization within an argument list, because 2205 otherwise aliasing issues may occur. */ 2206 2207 if (count_arglist != 1) 2208 return false; 2209 2210 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION 2211 || e->value.function.isym == NULL 2212 || e->value.function.isym->id != GFC_ISYM_TRIM) 2213 return false; 2214 2215 a = e->value.function.actual->expr; 2216 2217 if (a->expr_type != EXPR_VARIABLE) 2218 return false; 2219 2220 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */ 2221 2222 if (a->symtree->n.sym->attr.allocatable) 2223 return false; 2224 2225 /* Follow all references to find the correct place to put the newly 2226 created reference. FIXME: Also handle substring references and 2227 array references. Array references cause strange regressions at 2228 the moment. */ 2229 2230 if (a->ref) 2231 { 2232 for (rr = &(a->ref); *rr; rr = &((*rr)->next)) 2233 { 2234 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) 2235 return false; 2236 } 2237 } 2238 2239 strip_function_call (e); 2240 2241 if (e->ref == NULL) 2242 rr = &(e->ref); 2243 2244 /* Create the reference. */ 2245 2246 ref = gfc_get_ref (); 2247 ref->type = REF_SUBSTRING; 2248 2249 /* Set the start of the reference. */ 2250 2251 ref->u.ss.start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); 2252 2253 /* Build the function call to len_trim(x, gfc_default_integer_kind). */ 2254 2255 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_charlen_int_kind); 2256 2257 /* Set the end of the reference to the call to len_trim. */ 2258 2259 ref->u.ss.end = fcn; 2260 gcc_assert (rr != NULL && *rr == NULL); 2261 *rr = ref; 2262 return true; 2263 } 2264 2265 /* Optimize minloc(b), where b is rank 1 array, into 2266 (/ minloc(b, dim=1) /), and similarly for maxloc, 2267 as the latter forms are expanded inline. */ 2268 2269 static void 2270 optimize_minmaxloc (gfc_expr **e) 2271 { 2272 gfc_expr *fn = *e; 2273 gfc_actual_arglist *a; 2274 char *name, *p; 2275 2276 if (fn->rank != 1 2277 || fn->value.function.actual == NULL 2278 || fn->value.function.actual->expr == NULL 2279 || fn->value.function.actual->expr->rank != 1) 2280 return; 2281 2282 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); 2283 (*e)->shape = fn->shape; 2284 fn->rank = 0; 2285 fn->shape = NULL; 2286 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); 2287 2288 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); 2289 strcpy (name, fn->value.function.name); 2290 p = strstr (name, "loc0"); 2291 p[3] = '1'; 2292 fn->value.function.name = gfc_get_string ("%s", name); 2293 if (fn->value.function.actual->next) 2294 { 2295 a = fn->value.function.actual->next; 2296 gcc_assert (a->expr == NULL); 2297 } 2298 else 2299 { 2300 a = gfc_get_actual_arglist (); 2301 fn->value.function.actual->next = a; 2302 } 2303 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 2304 &fn->where); 2305 mpz_set_ui (a->expr->value.integer, 1); 2306 } 2307 2308 /* Callback function for code checking that we do not pass a DO variable to an 2309 INTENT(OUT) or INTENT(INOUT) dummy variable. */ 2310 2311 static int 2312 doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 2313 void *data ATTRIBUTE_UNUSED) 2314 { 2315 gfc_code *co; 2316 int i; 2317 gfc_formal_arglist *f; 2318 gfc_actual_arglist *a; 2319 gfc_code *cl; 2320 do_t loop, *lp; 2321 bool seen_goto; 2322 2323 co = *c; 2324 2325 /* If the doloop_list grew, we have to truncate it here. */ 2326 2327 if ((unsigned) doloop_level < doloop_list.length()) 2328 doloop_list.truncate (doloop_level); 2329 2330 seen_goto = false; 2331 switch (co->op) 2332 { 2333 case EXEC_DO: 2334 2335 if (co->ext.iterator && co->ext.iterator->var) 2336 loop.c = co; 2337 else 2338 loop.c = NULL; 2339 2340 loop.branch_level = if_level + select_level; 2341 loop.seen_goto = false; 2342 doloop_list.safe_push (loop); 2343 break; 2344 2345 /* If anything could transfer control away from a suspicious 2346 subscript, make sure to set seen_goto in the current DO loop 2347 (if any). */ 2348 case EXEC_GOTO: 2349 case EXEC_EXIT: 2350 case EXEC_STOP: 2351 case EXEC_ERROR_STOP: 2352 case EXEC_CYCLE: 2353 seen_goto = true; 2354 break; 2355 2356 case EXEC_OPEN: 2357 if (co->ext.open->err) 2358 seen_goto = true; 2359 break; 2360 2361 case EXEC_CLOSE: 2362 if (co->ext.close->err) 2363 seen_goto = true; 2364 break; 2365 2366 case EXEC_BACKSPACE: 2367 case EXEC_ENDFILE: 2368 case EXEC_REWIND: 2369 case EXEC_FLUSH: 2370 2371 if (co->ext.filepos->err) 2372 seen_goto = true; 2373 break; 2374 2375 case EXEC_INQUIRE: 2376 if (co->ext.filepos->err) 2377 seen_goto = true; 2378 break; 2379 2380 case EXEC_READ: 2381 case EXEC_WRITE: 2382 if (co->ext.dt->err || co->ext.dt->end || co->ext.dt->eor) 2383 seen_goto = true; 2384 break; 2385 2386 case EXEC_WAIT: 2387 if (co->ext.wait->err || co->ext.wait->end || co->ext.wait->eor) 2388 loop.seen_goto = true; 2389 break; 2390 2391 case EXEC_CALL: 2392 2393 if (co->resolved_sym == NULL) 2394 break; 2395 2396 f = gfc_sym_get_dummy_args (co->resolved_sym); 2397 2398 /* Withot a formal arglist, there is only unknown INTENT, 2399 which we don't check for. */ 2400 if (f == NULL) 2401 break; 2402 2403 a = co->ext.actual; 2404 2405 while (a && f) 2406 { 2407 FOR_EACH_VEC_ELT (doloop_list, i, lp) 2408 { 2409 gfc_symbol *do_sym; 2410 cl = lp->c; 2411 2412 if (cl == NULL) 2413 break; 2414 2415 do_sym = cl->ext.iterator->var->symtree->n.sym; 2416 2417 if (a->expr && a->expr->symtree && f->sym 2418 && a->expr->symtree->n.sym == do_sym) 2419 { 2420 if (f->sym->attr.intent == INTENT_OUT) 2421 gfc_error_now ("Variable %qs at %L set to undefined " 2422 "value inside loop beginning at %L as " 2423 "INTENT(OUT) argument to subroutine %qs", 2424 do_sym->name, &a->expr->where, 2425 &(doloop_list[i].c->loc), 2426 co->symtree->n.sym->name); 2427 else if (f->sym->attr.intent == INTENT_INOUT) 2428 gfc_error_now ("Variable %qs at %L not definable inside " 2429 "loop beginning at %L as INTENT(INOUT) " 2430 "argument to subroutine %qs", 2431 do_sym->name, &a->expr->where, 2432 &(doloop_list[i].c->loc), 2433 co->symtree->n.sym->name); 2434 } 2435 } 2436 a = a->next; 2437 f = f->next; 2438 } 2439 break; 2440 2441 default: 2442 break; 2443 } 2444 if (seen_goto && doloop_level > 0) 2445 doloop_list[doloop_level-1].seen_goto = true; 2446 2447 return 0; 2448 } 2449 2450 /* Callback function to warn about different things within DO loops. */ 2451 2452 static int 2453 do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 2454 void *data ATTRIBUTE_UNUSED) 2455 { 2456 do_t *last; 2457 2458 if (doloop_list.length () == 0) 2459 return 0; 2460 2461 if ((*e)->expr_type == EXPR_FUNCTION) 2462 do_intent (e); 2463 2464 last = &doloop_list.last(); 2465 if (last->seen_goto && !warn_do_subscript) 2466 return 0; 2467 2468 if ((*e)->expr_type == EXPR_VARIABLE) 2469 do_subscript (e); 2470 2471 return 0; 2472 } 2473 2474 typedef struct 2475 { 2476 gfc_symbol *sym; 2477 mpz_t val; 2478 } insert_index_t; 2479 2480 /* Callback function - if the expression is the variable in data->sym, 2481 replace it with a constant from data->val. */ 2482 2483 static int 2484 callback_insert_index (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 2485 void *data) 2486 { 2487 insert_index_t *d; 2488 gfc_expr *ex, *n; 2489 2490 ex = (*e); 2491 if (ex->expr_type != EXPR_VARIABLE) 2492 return 0; 2493 2494 d = (insert_index_t *) data; 2495 if (ex->symtree->n.sym != d->sym) 2496 return 0; 2497 2498 n = gfc_get_constant_expr (BT_INTEGER, ex->ts.kind, &ex->where); 2499 mpz_set (n->value.integer, d->val); 2500 2501 gfc_free_expr (ex); 2502 *e = n; 2503 return 0; 2504 } 2505 2506 /* In the expression e, replace occurrences of the variable sym with 2507 val. If this results in a constant expression, return true and 2508 return the value in ret. Return false if the expression already 2509 is a constant. Caller has to clear ret in that case. */ 2510 2511 static bool 2512 insert_index (gfc_expr *e, gfc_symbol *sym, mpz_t val, mpz_t ret) 2513 { 2514 gfc_expr *n; 2515 insert_index_t data; 2516 bool rc; 2517 2518 if (e->expr_type == EXPR_CONSTANT) 2519 return false; 2520 2521 n = gfc_copy_expr (e); 2522 data.sym = sym; 2523 mpz_init_set (data.val, val); 2524 gfc_expr_walker (&n, callback_insert_index, (void *) &data); 2525 2526 /* Suppress errors here - we could get errors here such as an 2527 out of bounds access for arrays, see PR 90563. */ 2528 gfc_push_suppress_errors (); 2529 gfc_simplify_expr (n, 0); 2530 gfc_pop_suppress_errors (); 2531 2532 if (n->expr_type == EXPR_CONSTANT) 2533 { 2534 rc = true; 2535 mpz_init_set (ret, n->value.integer); 2536 } 2537 else 2538 rc = false; 2539 2540 mpz_clear (data.val); 2541 gfc_free_expr (n); 2542 return rc; 2543 2544 } 2545 2546 /* Check array subscripts for possible out-of-bounds accesses in DO 2547 loops with constant bounds. */ 2548 2549 static int 2550 do_subscript (gfc_expr **e) 2551 { 2552 gfc_expr *v; 2553 gfc_array_ref *ar; 2554 gfc_ref *ref; 2555 int i,j; 2556 gfc_code *dl; 2557 do_t *lp; 2558 2559 v = *e; 2560 /* Constants are already checked. */ 2561 if (v->expr_type == EXPR_CONSTANT) 2562 return 0; 2563 2564 /* Wrong warnings will be generated in an associate list. */ 2565 if (in_assoc_list) 2566 return 0; 2567 2568 /* We already warned about this. */ 2569 if (v->do_not_warn) 2570 return 0; 2571 2572 v->do_not_warn = 1; 2573 2574 for (ref = v->ref; ref; ref = ref->next) 2575 { 2576 if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) 2577 { 2578 ar = & ref->u.ar; 2579 FOR_EACH_VEC_ELT (doloop_list, j, lp) 2580 { 2581 gfc_symbol *do_sym; 2582 mpz_t do_start, do_step, do_end; 2583 bool have_do_start, have_do_end; 2584 bool error_not_proven; 2585 int warn; 2586 int sgn; 2587 2588 dl = lp->c; 2589 if (dl == NULL) 2590 break; 2591 2592 /* If we are within a branch, or a goto or equivalent 2593 was seen in the DO loop before, then we cannot prove that 2594 this expression is actually evaluated. Don't do anything 2595 unless we want to see it all. */ 2596 error_not_proven = lp->seen_goto 2597 || lp->branch_level < if_level + select_level; 2598 2599 if (error_not_proven && !warn_do_subscript) 2600 break; 2601 2602 if (error_not_proven) 2603 warn = OPT_Wdo_subscript; 2604 else 2605 warn = 0; 2606 2607 do_sym = dl->ext.iterator->var->symtree->n.sym; 2608 if (do_sym->ts.type != BT_INTEGER) 2609 continue; 2610 2611 /* If we do not know about the stepsize, the loop may be zero trip. 2612 Do not warn in this case. */ 2613 2614 if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT) 2615 { 2616 sgn = mpz_cmp_ui (dl->ext.iterator->step->value.integer, 0); 2617 /* This can happen, but then the error has been 2618 reported previously. */ 2619 if (sgn == 0) 2620 continue; 2621 2622 mpz_init_set (do_step, dl->ext.iterator->step->value.integer); 2623 } 2624 2625 else 2626 continue; 2627 2628 if (dl->ext.iterator->start->expr_type == EXPR_CONSTANT) 2629 { 2630 have_do_start = true; 2631 mpz_init_set (do_start, dl->ext.iterator->start->value.integer); 2632 } 2633 else 2634 have_do_start = false; 2635 2636 if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT) 2637 { 2638 have_do_end = true; 2639 mpz_init_set (do_end, dl->ext.iterator->end->value.integer); 2640 } 2641 else 2642 have_do_end = false; 2643 2644 if (!have_do_start && !have_do_end) 2645 return 0; 2646 2647 /* No warning inside a zero-trip loop. */ 2648 if (have_do_start && have_do_end) 2649 { 2650 int cmp; 2651 2652 cmp = mpz_cmp (do_end, do_start); 2653 if ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0)) 2654 break; 2655 } 2656 2657 /* May have to correct the end value if the step does not equal 2658 one. */ 2659 if (have_do_start && have_do_end && mpz_cmp_ui (do_step, 1) != 0) 2660 { 2661 mpz_t diff, rem; 2662 2663 mpz_init (diff); 2664 mpz_init (rem); 2665 mpz_sub (diff, do_end, do_start); 2666 mpz_tdiv_r (rem, diff, do_step); 2667 mpz_sub (do_end, do_end, rem); 2668 mpz_clear (diff); 2669 mpz_clear (rem); 2670 } 2671 2672 for (i = 0; i< ar->dimen; i++) 2673 { 2674 mpz_t val; 2675 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_start 2676 && insert_index (ar->start[i], do_sym, do_start, val)) 2677 { 2678 if (ar->as->lower[i] 2679 && ar->as->lower[i]->expr_type == EXPR_CONSTANT 2680 && ar->as->lower[i]->ts.type == BT_INTEGER 2681 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) 2682 gfc_warning (warn, "Array reference at %L out of bounds " 2683 "(%ld < %ld) in loop beginning at %L", 2684 &ar->start[i]->where, mpz_get_si (val), 2685 mpz_get_si (ar->as->lower[i]->value.integer), 2686 &doloop_list[j].c->loc); 2687 2688 if (ar->as->upper[i] 2689 && ar->as->upper[i]->expr_type == EXPR_CONSTANT 2690 && ar->as->upper[i]->ts.type == BT_INTEGER 2691 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) 2692 gfc_warning (warn, "Array reference at %L out of bounds " 2693 "(%ld > %ld) in loop beginning at %L", 2694 &ar->start[i]->where, mpz_get_si (val), 2695 mpz_get_si (ar->as->upper[i]->value.integer), 2696 &doloop_list[j].c->loc); 2697 2698 mpz_clear (val); 2699 } 2700 2701 if (ar->dimen_type[i] == DIMEN_ELEMENT && have_do_end 2702 && insert_index (ar->start[i], do_sym, do_end, val)) 2703 { 2704 if (ar->as->lower[i] 2705 && ar->as->lower[i]->expr_type == EXPR_CONSTANT 2706 && ar->as->lower[i]->ts.type == BT_INTEGER 2707 && mpz_cmp (val, ar->as->lower[i]->value.integer) < 0) 2708 gfc_warning (warn, "Array reference at %L out of bounds " 2709 "(%ld < %ld) in loop beginning at %L", 2710 &ar->start[i]->where, mpz_get_si (val), 2711 mpz_get_si (ar->as->lower[i]->value.integer), 2712 &doloop_list[j].c->loc); 2713 2714 if (ar->as->upper[i] 2715 && ar->as->upper[i]->expr_type == EXPR_CONSTANT 2716 && ar->as->upper[i]->ts.type == BT_INTEGER 2717 && mpz_cmp (val, ar->as->upper[i]->value.integer) > 0) 2718 gfc_warning (warn, "Array reference at %L out of bounds " 2719 "(%ld > %ld) in loop beginning at %L", 2720 &ar->start[i]->where, mpz_get_si (val), 2721 mpz_get_si (ar->as->upper[i]->value.integer), 2722 &doloop_list[j].c->loc); 2723 2724 mpz_clear (val); 2725 } 2726 } 2727 } 2728 } 2729 } 2730 return 0; 2731 } 2732 /* Function for functions checking that we do not pass a DO variable 2733 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ 2734 2735 static int 2736 do_intent (gfc_expr **e) 2737 { 2738 gfc_formal_arglist *f; 2739 gfc_actual_arglist *a; 2740 gfc_expr *expr; 2741 gfc_code *dl; 2742 do_t *lp; 2743 int i; 2744 2745 expr = *e; 2746 if (expr->expr_type != EXPR_FUNCTION) 2747 return 0; 2748 2749 /* Intrinsic functions don't modify their arguments. */ 2750 2751 if (expr->value.function.isym) 2752 return 0; 2753 2754 f = gfc_sym_get_dummy_args (expr->symtree->n.sym); 2755 2756 /* Without a formal arglist, there is only unknown INTENT, 2757 which we don't check for. */ 2758 if (f == NULL) 2759 return 0; 2760 2761 a = expr->value.function.actual; 2762 2763 while (a && f) 2764 { 2765 FOR_EACH_VEC_ELT (doloop_list, i, lp) 2766 { 2767 gfc_symbol *do_sym; 2768 dl = lp->c; 2769 if (dl == NULL) 2770 break; 2771 2772 do_sym = dl->ext.iterator->var->symtree->n.sym; 2773 2774 if (a->expr && a->expr->symtree 2775 && a->expr->symtree->n.sym == do_sym) 2776 { 2777 if (f->sym->attr.intent == INTENT_OUT) 2778 gfc_error_now ("Variable %qs at %L set to undefined value " 2779 "inside loop beginning at %L as INTENT(OUT) " 2780 "argument to function %qs", do_sym->name, 2781 &a->expr->where, &doloop_list[i].c->loc, 2782 expr->symtree->n.sym->name); 2783 else if (f->sym->attr.intent == INTENT_INOUT) 2784 gfc_error_now ("Variable %qs at %L not definable inside loop" 2785 " beginning at %L as INTENT(INOUT) argument to" 2786 " function %qs", do_sym->name, 2787 &a->expr->where, &doloop_list[i].c->loc, 2788 expr->symtree->n.sym->name); 2789 } 2790 } 2791 a = a->next; 2792 f = f->next; 2793 } 2794 2795 return 0; 2796 } 2797 2798 static void 2799 doloop_warn (gfc_namespace *ns) 2800 { 2801 gfc_code_walker (&ns->code, doloop_code, do_function, NULL); 2802 2803 for (ns = ns->contained; ns; ns = ns->sibling) 2804 { 2805 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 2806 doloop_warn (ns); 2807 } 2808 } 2809 2810 /* This selction deals with inlining calls to MATMUL. */ 2811 2812 /* Replace calls to matmul outside of straight assignments with a temporary 2813 variable so that later inlining will work. */ 2814 2815 static int 2816 matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, 2817 void *data) 2818 { 2819 gfc_expr *e, *n; 2820 bool *found = (bool *) data; 2821 2822 e = *ep; 2823 2824 if (e->expr_type != EXPR_FUNCTION 2825 || e->value.function.isym == NULL 2826 || e->value.function.isym->id != GFC_ISYM_MATMUL) 2827 return 0; 2828 2829 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare 2830 || in_omp_atomic || in_where || in_assoc_list) 2831 return 0; 2832 2833 /* Check if this is already in the form c = matmul(a,b). */ 2834 2835 if ((*current_code)->expr2 == e) 2836 return 0; 2837 2838 n = create_var (e, "matmul"); 2839 2840 /* If create_var is unable to create a variable (for example if 2841 -fno-realloc-lhs is in force with a variable that does not have bounds 2842 known at compile-time), just return. */ 2843 2844 if (n == NULL) 2845 return 0; 2846 2847 *ep = n; 2848 *found = true; 2849 return 0; 2850 } 2851 2852 /* Set current_code and associated variables so that matmul_to_var_expr can 2853 work. */ 2854 2855 static int 2856 matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 2857 void *data ATTRIBUTE_UNUSED) 2858 { 2859 if (current_code != c) 2860 { 2861 current_code = c; 2862 inserted_block = NULL; 2863 changed_statement = NULL; 2864 } 2865 2866 return 0; 2867 } 2868 2869 2870 /* Take a statement of the shape c = matmul(a,b) and create temporaries 2871 for a and b if there is a dependency between the arguments and the 2872 result variable or if a or b are the result of calculations that cannot 2873 be handled by the inliner. */ 2874 2875 static int 2876 matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 2877 void *data ATTRIBUTE_UNUSED) 2878 { 2879 gfc_expr *expr1, *expr2; 2880 gfc_code *co; 2881 gfc_actual_arglist *a, *b; 2882 bool a_tmp, b_tmp; 2883 gfc_expr *matrix_a, *matrix_b; 2884 bool conjg_a, conjg_b, transpose_a, transpose_b; 2885 2886 co = *c; 2887 2888 if (co->op != EXEC_ASSIGN) 2889 return 0; 2890 2891 if (forall_level > 0 || iterator_level > 0 || in_omp_workshare 2892 || in_omp_atomic || in_where) 2893 return 0; 2894 2895 /* This has some duplication with inline_matmul_assign. This 2896 is because the creation of temporary variables could still fail, 2897 and inline_matmul_assign still needs to be able to handle these 2898 cases. */ 2899 expr1 = co->expr1; 2900 expr2 = co->expr2; 2901 2902 if (expr2->expr_type != EXPR_FUNCTION 2903 || expr2->value.function.isym == NULL 2904 || expr2->value.function.isym->id != GFC_ISYM_MATMUL) 2905 return 0; 2906 2907 a_tmp = false; 2908 a = expr2->value.function.actual; 2909 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); 2910 if (matrix_a != NULL) 2911 { 2912 if (matrix_a->expr_type == EXPR_VARIABLE 2913 && (gfc_check_dependency (matrix_a, expr1, true) 2914 || gfc_has_dimen_vector_ref (matrix_a))) 2915 a_tmp = true; 2916 } 2917 else 2918 a_tmp = true; 2919 2920 b_tmp = false; 2921 b = a->next; 2922 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); 2923 if (matrix_b != NULL) 2924 { 2925 if (matrix_b->expr_type == EXPR_VARIABLE 2926 && (gfc_check_dependency (matrix_b, expr1, true) 2927 || gfc_has_dimen_vector_ref (matrix_b))) 2928 b_tmp = true; 2929 } 2930 else 2931 b_tmp = true; 2932 2933 if (!a_tmp && !b_tmp) 2934 return 0; 2935 2936 current_code = c; 2937 inserted_block = NULL; 2938 changed_statement = NULL; 2939 if (a_tmp) 2940 { 2941 gfc_expr *at; 2942 at = create_var (a->expr,"mma"); 2943 if (at) 2944 a->expr = at; 2945 } 2946 if (b_tmp) 2947 { 2948 gfc_expr *bt; 2949 bt = create_var (b->expr,"mmb"); 2950 if (bt) 2951 b->expr = bt; 2952 } 2953 return 0; 2954 } 2955 2956 /* Auxiliary function to build and simplify an array inquiry function. 2957 dim is zero-based. */ 2958 2959 static gfc_expr * 2960 get_array_inq_function (gfc_isym_id id, gfc_expr *e, int dim, int okind = 0) 2961 { 2962 gfc_expr *fcn; 2963 gfc_expr *dim_arg, *kind; 2964 const char *name; 2965 gfc_expr *ec; 2966 2967 switch (id) 2968 { 2969 case GFC_ISYM_LBOUND: 2970 name = "_gfortran_lbound"; 2971 break; 2972 2973 case GFC_ISYM_UBOUND: 2974 name = "_gfortran_ubound"; 2975 break; 2976 2977 case GFC_ISYM_SIZE: 2978 name = "_gfortran_size"; 2979 break; 2980 2981 default: 2982 gcc_unreachable (); 2983 } 2984 2985 dim_arg = gfc_get_int_expr (gfc_default_integer_kind, &e->where, dim); 2986 if (okind != 0) 2987 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 2988 okind); 2989 else 2990 kind = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 2991 gfc_index_integer_kind); 2992 2993 ec = gfc_copy_expr (e); 2994 2995 /* No bounds checking, this will be done before the loops if -fcheck=bounds 2996 is in effect. */ 2997 ec->no_bounds_check = 1; 2998 fcn = gfc_build_intrinsic_call (current_ns, id, name, e->where, 3, 2999 ec, dim_arg, kind); 3000 gfc_simplify_expr (fcn, 0); 3001 fcn->no_bounds_check = 1; 3002 return fcn; 3003 } 3004 3005 /* Builds a logical expression. */ 3006 3007 static gfc_expr* 3008 build_logical_expr (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) 3009 { 3010 gfc_typespec ts; 3011 gfc_expr *res; 3012 3013 ts.type = BT_LOGICAL; 3014 ts.kind = gfc_default_logical_kind; 3015 res = gfc_get_expr (); 3016 res->where = e1->where; 3017 res->expr_type = EXPR_OP; 3018 res->value.op.op = op; 3019 res->value.op.op1 = e1; 3020 res->value.op.op2 = e2; 3021 res->ts = ts; 3022 3023 return res; 3024 } 3025 3026 3027 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes 3028 compatible typespecs. */ 3029 3030 static gfc_expr * 3031 get_operand (gfc_intrinsic_op op, gfc_expr *e1, gfc_expr *e2) 3032 { 3033 gfc_expr *res; 3034 3035 res = gfc_get_expr (); 3036 res->ts = e1->ts; 3037 res->where = e1->where; 3038 res->expr_type = EXPR_OP; 3039 res->value.op.op = op; 3040 res->value.op.op1 = e1; 3041 res->value.op.op2 = e2; 3042 gfc_simplify_expr (res, 0); 3043 return res; 3044 } 3045 3046 /* Generate the IF statement for a runtime check if we want to do inlining or 3047 not - putting in the code for both branches and putting it into the syntax 3048 tree is the caller's responsibility. For fixed array sizes, this should be 3049 removed by DCE. Only called for rank-two matrices A and B. */ 3050 3051 static gfc_code * 3052 inline_limit_check (gfc_expr *a, gfc_expr *b, int limit) 3053 { 3054 gfc_expr *inline_limit; 3055 gfc_code *if_1, *if_2, *else_2; 3056 gfc_expr *b2, *a2, *a1, *m1, *m2; 3057 gfc_typespec ts; 3058 gfc_expr *cond; 3059 3060 /* Calculation is done in real to avoid integer overflow. */ 3061 3062 inline_limit = gfc_get_constant_expr (BT_REAL, gfc_default_real_kind, 3063 &a->where); 3064 mpfr_set_si (inline_limit->value.real, limit, GFC_RND_MODE); 3065 mpfr_pow_ui (inline_limit->value.real, inline_limit->value.real, 3, 3066 GFC_RND_MODE); 3067 3068 a1 = get_array_inq_function (GFC_ISYM_SIZE, a, 1); 3069 a2 = get_array_inq_function (GFC_ISYM_SIZE, a, 2); 3070 b2 = get_array_inq_function (GFC_ISYM_SIZE, b, 2); 3071 3072 gfc_clear_ts (&ts); 3073 ts.type = BT_REAL; 3074 ts.kind = gfc_default_real_kind; 3075 gfc_convert_type_warn (a1, &ts, 2, 0); 3076 gfc_convert_type_warn (a2, &ts, 2, 0); 3077 gfc_convert_type_warn (b2, &ts, 2, 0); 3078 3079 m1 = get_operand (INTRINSIC_TIMES, a1, a2); 3080 m2 = get_operand (INTRINSIC_TIMES, m1, b2); 3081 3082 cond = build_logical_expr (INTRINSIC_LE, m2, inline_limit); 3083 gfc_simplify_expr (cond, 0); 3084 3085 else_2 = XCNEW (gfc_code); 3086 else_2->op = EXEC_IF; 3087 else_2->loc = a->where; 3088 3089 if_2 = XCNEW (gfc_code); 3090 if_2->op = EXEC_IF; 3091 if_2->expr1 = cond; 3092 if_2->loc = a->where; 3093 if_2->block = else_2; 3094 3095 if_1 = XCNEW (gfc_code); 3096 if_1->op = EXEC_IF; 3097 if_1->block = if_2; 3098 if_1->loc = a->where; 3099 3100 return if_1; 3101 } 3102 3103 3104 /* Insert code to issue a runtime error if the expressions are not equal. */ 3105 3106 static gfc_code * 3107 runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg) 3108 { 3109 gfc_expr *cond; 3110 gfc_code *if_1, *if_2; 3111 gfc_code *c; 3112 gfc_actual_arglist *a1, *a2, *a3; 3113 3114 gcc_assert (e1->where.lb); 3115 /* Build the call to runtime_error. */ 3116 c = XCNEW (gfc_code); 3117 c->op = EXEC_CALL; 3118 c->loc = e1->where; 3119 3120 /* Get a null-terminated message string. */ 3121 3122 a1 = gfc_get_actual_arglist (); 3123 a1->expr = gfc_get_character_expr (gfc_default_character_kind, &e1->where, 3124 msg, strlen(msg)+1); 3125 c->ext.actual = a1; 3126 3127 /* Pass the value of the first expression. */ 3128 a2 = gfc_get_actual_arglist (); 3129 a2->expr = gfc_copy_expr (e1); 3130 a1->next = a2; 3131 3132 /* Pass the value of the second expression. */ 3133 a3 = gfc_get_actual_arglist (); 3134 a3->expr = gfc_copy_expr (e2); 3135 a2->next = a3; 3136 3137 gfc_check_fe_runtime_error (c->ext.actual); 3138 gfc_resolve_fe_runtime_error (c); 3139 3140 if_2 = XCNEW (gfc_code); 3141 if_2->op = EXEC_IF; 3142 if_2->loc = e1->where; 3143 if_2->next = c; 3144 3145 if_1 = XCNEW (gfc_code); 3146 if_1->op = EXEC_IF; 3147 if_1->block = if_2; 3148 if_1->loc = e1->where; 3149 3150 cond = build_logical_expr (INTRINSIC_NE, e1, e2); 3151 gfc_simplify_expr (cond, 0); 3152 if_2->expr1 = cond; 3153 3154 return if_1; 3155 } 3156 3157 /* Handle matrix reallocation. Caller is responsible to insert into 3158 the code tree. 3159 3160 For the two-dimensional case, build 3161 3162 if (allocated(c)) then 3163 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then 3164 deallocate(c) 3165 allocate (c(size(a,1), size(b,2))) 3166 end if 3167 else 3168 allocate (c(size(a,1),size(b,2))) 3169 end if 3170 3171 and for the other cases correspondingly. 3172 */ 3173 3174 static gfc_code * 3175 matmul_lhs_realloc (gfc_expr *c, gfc_expr *a, gfc_expr *b, 3176 enum matrix_case m_case) 3177 { 3178 3179 gfc_expr *allocated, *alloc_expr; 3180 gfc_code *if_alloc_1, *if_alloc_2, *if_size_1, *if_size_2; 3181 gfc_code *else_alloc; 3182 gfc_code *deallocate, *allocate1, *allocate_else; 3183 gfc_array_ref *ar; 3184 gfc_expr *cond, *ne1, *ne2; 3185 3186 if (warn_realloc_lhs) 3187 gfc_warning (OPT_Wrealloc_lhs, 3188 "Code for reallocating the allocatable array at %L will " 3189 "be added", &c->where); 3190 3191 alloc_expr = gfc_copy_expr (c); 3192 3193 ar = gfc_find_array_ref (alloc_expr); 3194 gcc_assert (ar && ar->type == AR_FULL); 3195 3196 /* c comes in as a full ref. Change it into a copy and make it into an 3197 element ref so it has the right form for ALLOCATE. In the same 3198 switch statement, also generate the size comparison for the secod IF 3199 statement. */ 3200 3201 ar->type = AR_ELEMENT; 3202 3203 switch (m_case) 3204 { 3205 case A2B2: 3206 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); 3207 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); 3208 ne1 = build_logical_expr (INTRINSIC_NE, 3209 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3210 get_array_inq_function (GFC_ISYM_SIZE, a, 1)); 3211 ne2 = build_logical_expr (INTRINSIC_NE, 3212 get_array_inq_function (GFC_ISYM_SIZE, c, 2), 3213 get_array_inq_function (GFC_ISYM_SIZE, b, 2)); 3214 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); 3215 break; 3216 3217 case A2B2T: 3218 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); 3219 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); 3220 3221 ne1 = build_logical_expr (INTRINSIC_NE, 3222 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3223 get_array_inq_function (GFC_ISYM_SIZE, a, 1)); 3224 ne2 = build_logical_expr (INTRINSIC_NE, 3225 get_array_inq_function (GFC_ISYM_SIZE, c, 2), 3226 get_array_inq_function (GFC_ISYM_SIZE, b, 1)); 3227 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); 3228 break; 3229 3230 case A2TB2: 3231 3232 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); 3233 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); 3234 3235 ne1 = build_logical_expr (INTRINSIC_NE, 3236 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3237 get_array_inq_function (GFC_ISYM_SIZE, a, 2)); 3238 ne2 = build_logical_expr (INTRINSIC_NE, 3239 get_array_inq_function (GFC_ISYM_SIZE, c, 2), 3240 get_array_inq_function (GFC_ISYM_SIZE, b, 2)); 3241 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); 3242 break; 3243 3244 case A2B1: 3245 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 1); 3246 cond = build_logical_expr (INTRINSIC_NE, 3247 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3248 get_array_inq_function (GFC_ISYM_SIZE, a, 2)); 3249 break; 3250 3251 case A1B2: 3252 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, b, 2); 3253 cond = build_logical_expr (INTRINSIC_NE, 3254 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3255 get_array_inq_function (GFC_ISYM_SIZE, b, 2)); 3256 break; 3257 3258 case A2TB2T: 3259 /* This can only happen for BLAS, we do not handle that case in 3260 inline mamtul. */ 3261 ar->start[0] = get_array_inq_function (GFC_ISYM_SIZE, a, 2); 3262 ar->start[1] = get_array_inq_function (GFC_ISYM_SIZE, b, 1); 3263 3264 ne1 = build_logical_expr (INTRINSIC_NE, 3265 get_array_inq_function (GFC_ISYM_SIZE, c, 1), 3266 get_array_inq_function (GFC_ISYM_SIZE, a, 2)); 3267 ne2 = build_logical_expr (INTRINSIC_NE, 3268 get_array_inq_function (GFC_ISYM_SIZE, c, 2), 3269 get_array_inq_function (GFC_ISYM_SIZE, b, 1)); 3270 3271 cond = build_logical_expr (INTRINSIC_OR, ne1, ne2); 3272 break; 3273 3274 default: 3275 gcc_unreachable(); 3276 3277 } 3278 3279 gfc_simplify_expr (cond, 0); 3280 3281 /* We need two identical allocate statements in two 3282 branches of the IF statement. */ 3283 3284 allocate1 = XCNEW (gfc_code); 3285 allocate1->op = EXEC_ALLOCATE; 3286 allocate1->ext.alloc.list = gfc_get_alloc (); 3287 allocate1->loc = c->where; 3288 allocate1->ext.alloc.list->expr = gfc_copy_expr (alloc_expr); 3289 3290 allocate_else = XCNEW (gfc_code); 3291 allocate_else->op = EXEC_ALLOCATE; 3292 allocate_else->ext.alloc.list = gfc_get_alloc (); 3293 allocate_else->loc = c->where; 3294 allocate_else->ext.alloc.list->expr = alloc_expr; 3295 3296 allocated = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ALLOCATED, 3297 "_gfortran_allocated", c->where, 3298 1, gfc_copy_expr (c)); 3299 3300 deallocate = XCNEW (gfc_code); 3301 deallocate->op = EXEC_DEALLOCATE; 3302 deallocate->ext.alloc.list = gfc_get_alloc (); 3303 deallocate->ext.alloc.list->expr = gfc_copy_expr (c); 3304 deallocate->next = allocate1; 3305 deallocate->loc = c->where; 3306 3307 if_size_2 = XCNEW (gfc_code); 3308 if_size_2->op = EXEC_IF; 3309 if_size_2->expr1 = cond; 3310 if_size_2->loc = c->where; 3311 if_size_2->next = deallocate; 3312 3313 if_size_1 = XCNEW (gfc_code); 3314 if_size_1->op = EXEC_IF; 3315 if_size_1->block = if_size_2; 3316 if_size_1->loc = c->where; 3317 3318 else_alloc = XCNEW (gfc_code); 3319 else_alloc->op = EXEC_IF; 3320 else_alloc->loc = c->where; 3321 else_alloc->next = allocate_else; 3322 3323 if_alloc_2 = XCNEW (gfc_code); 3324 if_alloc_2->op = EXEC_IF; 3325 if_alloc_2->expr1 = allocated; 3326 if_alloc_2->loc = c->where; 3327 if_alloc_2->next = if_size_1; 3328 if_alloc_2->block = else_alloc; 3329 3330 if_alloc_1 = XCNEW (gfc_code); 3331 if_alloc_1->op = EXEC_IF; 3332 if_alloc_1->block = if_alloc_2; 3333 if_alloc_1->loc = c->where; 3334 3335 return if_alloc_1; 3336 } 3337 3338 /* Callback function for has_function_or_op. */ 3339 3340 static int 3341 is_function_or_op (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 3342 void *data ATTRIBUTE_UNUSED) 3343 { 3344 if ((*e) == 0) 3345 return 0; 3346 else 3347 return (*e)->expr_type == EXPR_FUNCTION 3348 || (*e)->expr_type == EXPR_OP; 3349 } 3350 3351 /* Returns true if the expression contains a function. */ 3352 3353 static bool 3354 has_function_or_op (gfc_expr **e) 3355 { 3356 if (e == NULL) 3357 return false; 3358 else 3359 return gfc_expr_walker (e, is_function_or_op, NULL); 3360 } 3361 3362 /* Freeze (assign to a temporary variable) a single expression. */ 3363 3364 static void 3365 freeze_expr (gfc_expr **ep) 3366 { 3367 gfc_expr *ne; 3368 if (has_function_or_op (ep)) 3369 { 3370 ne = create_var (*ep, "freeze"); 3371 *ep = ne; 3372 } 3373 } 3374 3375 /* Go through an expression's references and assign them to temporary 3376 variables if they contain functions. This is usually done prior to 3377 front-end scalarization to avoid multiple invocations of functions. */ 3378 3379 static void 3380 freeze_references (gfc_expr *e) 3381 { 3382 gfc_ref *r; 3383 gfc_array_ref *ar; 3384 int i; 3385 3386 for (r=e->ref; r; r=r->next) 3387 { 3388 if (r->type == REF_SUBSTRING) 3389 { 3390 if (r->u.ss.start != NULL) 3391 freeze_expr (&r->u.ss.start); 3392 3393 if (r->u.ss.end != NULL) 3394 freeze_expr (&r->u.ss.end); 3395 } 3396 else if (r->type == REF_ARRAY) 3397 { 3398 ar = &r->u.ar; 3399 switch (ar->type) 3400 { 3401 case AR_FULL: 3402 break; 3403 3404 case AR_SECTION: 3405 for (i=0; i<ar->dimen; i++) 3406 { 3407 if (ar->dimen_type[i] == DIMEN_RANGE) 3408 { 3409 freeze_expr (&ar->start[i]); 3410 freeze_expr (&ar->end[i]); 3411 freeze_expr (&ar->stride[i]); 3412 } 3413 else if (ar->dimen_type[i] == DIMEN_ELEMENT) 3414 { 3415 freeze_expr (&ar->start[i]); 3416 } 3417 } 3418 break; 3419 3420 case AR_ELEMENT: 3421 for (i=0; i<ar->dimen; i++) 3422 freeze_expr (&ar->start[i]); 3423 break; 3424 3425 default: 3426 break; 3427 } 3428 } 3429 } 3430 } 3431 3432 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */ 3433 3434 static gfc_expr * 3435 convert_to_index_kind (gfc_expr *e) 3436 { 3437 gfc_expr *res; 3438 3439 gcc_assert (e != NULL); 3440 3441 res = gfc_copy_expr (e); 3442 3443 gcc_assert (e->ts.type == BT_INTEGER); 3444 3445 if (res->ts.kind != gfc_index_integer_kind) 3446 { 3447 gfc_typespec ts; 3448 gfc_clear_ts (&ts); 3449 ts.type = BT_INTEGER; 3450 ts.kind = gfc_index_integer_kind; 3451 3452 gfc_convert_type_warn (e, &ts, 2, 0); 3453 } 3454 3455 return res; 3456 } 3457 3458 /* Function to create a DO loop including creation of the 3459 iteration variable. gfc_expr are copied.*/ 3460 3461 static gfc_code * 3462 create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where, 3463 gfc_namespace *ns, char *vname) 3464 { 3465 3466 char name[GFC_MAX_SYMBOL_LEN +1]; 3467 gfc_symtree *symtree; 3468 gfc_symbol *symbol; 3469 gfc_expr *i; 3470 gfc_code *n, *n2; 3471 3472 /* Create an expression for the iteration variable. */ 3473 if (vname) 3474 sprintf (name, "__var_%d_do_%s", var_num++, vname); 3475 else 3476 sprintf (name, "__var_%d_do", var_num++); 3477 3478 3479 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) 3480 gcc_unreachable (); 3481 3482 /* Create the loop variable. */ 3483 3484 symbol = symtree->n.sym; 3485 symbol->ts.type = BT_INTEGER; 3486 symbol->ts.kind = gfc_index_integer_kind; 3487 symbol->attr.flavor = FL_VARIABLE; 3488 symbol->attr.referenced = 1; 3489 symbol->attr.dimension = 0; 3490 symbol->attr.fe_temp = 1; 3491 gfc_commit_symbol (symbol); 3492 3493 i = gfc_get_expr (); 3494 i->expr_type = EXPR_VARIABLE; 3495 i->ts = symbol->ts; 3496 i->rank = 0; 3497 i->where = *where; 3498 i->symtree = symtree; 3499 3500 /* ... and the nested DO statements. */ 3501 n = XCNEW (gfc_code); 3502 n->op = EXEC_DO; 3503 n->loc = *where; 3504 n->ext.iterator = gfc_get_iterator (); 3505 n->ext.iterator->var = i; 3506 n->ext.iterator->start = convert_to_index_kind (start); 3507 n->ext.iterator->end = convert_to_index_kind (end); 3508 if (step) 3509 n->ext.iterator->step = convert_to_index_kind (step); 3510 else 3511 n->ext.iterator->step = gfc_get_int_expr (gfc_index_integer_kind, 3512 where, 1); 3513 3514 n2 = XCNEW (gfc_code); 3515 n2->op = EXEC_DO; 3516 n2->loc = *where; 3517 n2->next = NULL; 3518 n->block = n2; 3519 return n; 3520 } 3521 3522 /* Get the upper bound of the DO loops for matmul along a dimension. This 3523 is one-based. */ 3524 3525 static gfc_expr* 3526 get_size_m1 (gfc_expr *e, int dimen) 3527 { 3528 mpz_t size; 3529 gfc_expr *res; 3530 3531 if (gfc_array_dimen_size (e, dimen - 1, &size)) 3532 { 3533 res = gfc_get_constant_expr (BT_INTEGER, 3534 gfc_index_integer_kind, &e->where); 3535 mpz_sub_ui (res->value.integer, size, 1); 3536 mpz_clear (size); 3537 } 3538 else 3539 { 3540 res = get_operand (INTRINSIC_MINUS, 3541 get_array_inq_function (GFC_ISYM_SIZE, e, dimen), 3542 gfc_get_int_expr (gfc_index_integer_kind, 3543 &e->where, 1)); 3544 gfc_simplify_expr (res, 0); 3545 } 3546 3547 return res; 3548 } 3549 3550 /* Function to return a scalarized expression. It is assumed that indices are 3551 zero based to make generation of DO loops easier. A zero as index will 3552 access the first element along a dimension. Single element references will 3553 be skipped. A NULL as an expression will be replaced by a full reference. 3554 This assumes that the index loops have gfc_index_integer_kind, and that all 3555 references have been frozen. */ 3556 3557 static gfc_expr* 3558 scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index) 3559 { 3560 gfc_array_ref *ar; 3561 int i; 3562 int rank; 3563 gfc_expr *e; 3564 int i_index; 3565 bool was_fullref; 3566 3567 e = gfc_copy_expr(e_in); 3568 3569 rank = e->rank; 3570 3571 ar = gfc_find_array_ref (e); 3572 3573 /* We scalarize count_index variables, reducing the rank by count_index. */ 3574 3575 e->rank = rank - count_index; 3576 3577 was_fullref = ar->type == AR_FULL; 3578 3579 if (e->rank == 0) 3580 ar->type = AR_ELEMENT; 3581 else 3582 ar->type = AR_SECTION; 3583 3584 /* Loop over the indices. For each index, create the expression 3585 index * stride + lbound(e, dim). */ 3586 3587 i_index = 0; 3588 for (i=0; i < ar->dimen; i++) 3589 { 3590 if (was_fullref || ar->dimen_type[i] == DIMEN_RANGE) 3591 { 3592 if (index[i_index] != NULL) 3593 { 3594 gfc_expr *lbound, *nindex; 3595 gfc_expr *loopvar; 3596 3597 loopvar = gfc_copy_expr (index[i_index]); 3598 3599 if (ar->stride[i]) 3600 { 3601 gfc_expr *tmp; 3602 3603 tmp = gfc_copy_expr(ar->stride[i]); 3604 if (tmp->ts.kind != gfc_index_integer_kind) 3605 { 3606 gfc_typespec ts; 3607 gfc_clear_ts (&ts); 3608 ts.type = BT_INTEGER; 3609 ts.kind = gfc_index_integer_kind; 3610 gfc_convert_type (tmp, &ts, 2); 3611 } 3612 nindex = get_operand (INTRINSIC_TIMES, loopvar, tmp); 3613 } 3614 else 3615 nindex = loopvar; 3616 3617 /* Calculate the lower bound of the expression. */ 3618 if (ar->start[i]) 3619 { 3620 lbound = gfc_copy_expr (ar->start[i]); 3621 if (lbound->ts.kind != gfc_index_integer_kind) 3622 { 3623 gfc_typespec ts; 3624 gfc_clear_ts (&ts); 3625 ts.type = BT_INTEGER; 3626 ts.kind = gfc_index_integer_kind; 3627 gfc_convert_type (lbound, &ts, 2); 3628 3629 } 3630 } 3631 else 3632 { 3633 gfc_expr *lbound_e; 3634 gfc_ref *ref; 3635 3636 lbound_e = gfc_copy_expr (e_in); 3637 3638 for (ref = lbound_e->ref; ref; ref = ref->next) 3639 if (ref->type == REF_ARRAY 3640 && (ref->u.ar.type == AR_FULL 3641 || ref->u.ar.type == AR_SECTION)) 3642 break; 3643 3644 if (ref->next) 3645 { 3646 gfc_free_ref_list (ref->next); 3647 ref->next = NULL; 3648 } 3649 3650 if (!was_fullref) 3651 { 3652 /* Look at full individual sections, like a(:). The first index 3653 is the lbound of a full ref. */ 3654 int j; 3655 gfc_array_ref *ar; 3656 int to; 3657 3658 ar = &ref->u.ar; 3659 3660 /* For assumed size, we need to keep around the final 3661 reference in order not to get an error on resolution 3662 below, and we cannot use AR_FULL. */ 3663 3664 if (ar->as->type == AS_ASSUMED_SIZE) 3665 { 3666 ar->type = AR_SECTION; 3667 to = ar->dimen - 1; 3668 } 3669 else 3670 { 3671 to = ar->dimen; 3672 ar->type = AR_FULL; 3673 } 3674 3675 for (j = 0; j < to; j++) 3676 { 3677 gfc_free_expr (ar->start[j]); 3678 ar->start[j] = NULL; 3679 gfc_free_expr (ar->end[j]); 3680 ar->end[j] = NULL; 3681 gfc_free_expr (ar->stride[j]); 3682 ar->stride[j] = NULL; 3683 } 3684 3685 /* We have to get rid of the shape, if there is one. Do 3686 so by freeing it and calling gfc_resolve to rebuild 3687 it, if necessary. */ 3688 3689 if (lbound_e->shape) 3690 gfc_free_shape (&(lbound_e->shape), lbound_e->rank); 3691 3692 lbound_e->rank = ar->dimen; 3693 gfc_resolve_expr (lbound_e); 3694 } 3695 lbound = get_array_inq_function (GFC_ISYM_LBOUND, lbound_e, 3696 i + 1); 3697 gfc_free_expr (lbound_e); 3698 } 3699 3700 ar->dimen_type[i] = DIMEN_ELEMENT; 3701 3702 gfc_free_expr (ar->start[i]); 3703 ar->start[i] = get_operand (INTRINSIC_PLUS, nindex, lbound); 3704 3705 gfc_free_expr (ar->end[i]); 3706 ar->end[i] = NULL; 3707 gfc_free_expr (ar->stride[i]); 3708 ar->stride[i] = NULL; 3709 gfc_simplify_expr (ar->start[i], 0); 3710 } 3711 else if (was_fullref) 3712 { 3713 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented"); 3714 } 3715 i_index ++; 3716 } 3717 } 3718 3719 /* Bounds checking will be done before the loops if -fcheck=bounds 3720 is in effect. */ 3721 e->no_bounds_check = 1; 3722 return e; 3723 } 3724 3725 /* Helper function to check for a dimen vector as subscript. */ 3726 3727 bool 3728 gfc_has_dimen_vector_ref (gfc_expr *e) 3729 { 3730 gfc_array_ref *ar; 3731 int i; 3732 3733 ar = gfc_find_array_ref (e); 3734 gcc_assert (ar); 3735 if (ar->type == AR_FULL) 3736 return false; 3737 3738 for (i=0; i<ar->dimen; i++) 3739 if (ar->dimen_type[i] == DIMEN_VECTOR) 3740 return true; 3741 3742 return false; 3743 } 3744 3745 /* If handed an expression of the form 3746 3747 TRANSPOSE(CONJG(A)) 3748 3749 check if A can be handled by matmul and return if there is an uneven number 3750 of CONJG calls. Return a pointer to the array when everything is OK, NULL 3751 otherwise. The caller has to check for the correct rank. */ 3752 3753 static gfc_expr* 3754 check_conjg_transpose_variable (gfc_expr *e, bool *conjg, bool *transpose) 3755 { 3756 *conjg = false; 3757 *transpose = false; 3758 3759 do 3760 { 3761 if (e->expr_type == EXPR_VARIABLE) 3762 { 3763 gcc_assert (e->rank == 1 || e->rank == 2); 3764 return e; 3765 } 3766 else if (e->expr_type == EXPR_FUNCTION) 3767 { 3768 if (e->value.function.isym == NULL) 3769 return NULL; 3770 3771 if (e->value.function.isym->id == GFC_ISYM_CONJG) 3772 *conjg = !*conjg; 3773 else if (e->value.function.isym->id == GFC_ISYM_TRANSPOSE) 3774 *transpose = !*transpose; 3775 else return NULL; 3776 } 3777 else 3778 return NULL; 3779 3780 e = e->value.function.actual->expr; 3781 } 3782 while(1); 3783 3784 return NULL; 3785 } 3786 3787 /* Macros for unified error messages. */ 3788 3789 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \ 3790 "dimension 1: is %ld, should be %ld") 3791 3792 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \ 3793 "(%ld/%ld)") 3794 3795 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \ 3796 "(%ld/%ld)") 3797 3798 3799 /* Inline assignments of the form c = matmul(a,b). 3800 Handle only the cases currently where b and c are rank-two arrays. 3801 3802 This basically translates the code to 3803 3804 BLOCK 3805 integer i,j,k 3806 c = 0 3807 do j=0, size(b,2)-1 3808 do k=0, size(a, 2)-1 3809 do i=0, size(a, 1)-1 3810 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) = 3811 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) + 3812 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) * 3813 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2)) 3814 end do 3815 end do 3816 end do 3817 END BLOCK 3818 3819 */ 3820 3821 static int 3822 inline_matmul_assign (gfc_code **c, int *walk_subtrees, 3823 void *data ATTRIBUTE_UNUSED) 3824 { 3825 gfc_code *co = *c; 3826 gfc_expr *expr1, *expr2; 3827 gfc_expr *matrix_a, *matrix_b; 3828 gfc_actual_arglist *a, *b; 3829 gfc_code *do_1, *do_2, *do_3, *assign_zero, *assign_matmul; 3830 gfc_expr *zero_e; 3831 gfc_expr *u1, *u2, *u3; 3832 gfc_expr *list[2]; 3833 gfc_expr *ascalar, *bscalar, *cscalar; 3834 gfc_expr *mult; 3835 gfc_expr *var_1, *var_2, *var_3; 3836 gfc_expr *zero; 3837 gfc_namespace *ns; 3838 gfc_intrinsic_op op_times, op_plus; 3839 enum matrix_case m_case; 3840 int i; 3841 gfc_code *if_limit = NULL; 3842 gfc_code **next_code_point; 3843 bool conjg_a, conjg_b, transpose_a, transpose_b; 3844 bool realloc_c; 3845 3846 if (co->op != EXEC_ASSIGN) 3847 return 0; 3848 3849 if (in_where || in_assoc_list) 3850 return 0; 3851 3852 /* The BLOCKS generated for the temporary variables and FORALL don't 3853 mix. */ 3854 if (forall_level > 0) 3855 return 0; 3856 3857 /* For now don't do anything in OpenMP workshare, it confuses 3858 its translation, which expects only the allowed statements in there. 3859 We should figure out how to parallelize this eventually. */ 3860 if (in_omp_workshare || in_omp_atomic) 3861 return 0; 3862 3863 expr1 = co->expr1; 3864 expr2 = co->expr2; 3865 if (expr2->expr_type != EXPR_FUNCTION 3866 || expr2->value.function.isym == NULL 3867 || expr2->value.function.isym->id != GFC_ISYM_MATMUL) 3868 return 0; 3869 3870 current_code = c; 3871 inserted_block = NULL; 3872 changed_statement = NULL; 3873 3874 a = expr2->value.function.actual; 3875 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); 3876 if (matrix_a == NULL) 3877 return 0; 3878 3879 b = a->next; 3880 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); 3881 if (matrix_b == NULL) 3882 return 0; 3883 3884 if (gfc_has_dimen_vector_ref (expr1) || gfc_has_dimen_vector_ref (matrix_a) 3885 || gfc_has_dimen_vector_ref (matrix_b)) 3886 return 0; 3887 3888 /* We do not handle data dependencies yet. */ 3889 if (gfc_check_dependency (expr1, matrix_a, true) 3890 || gfc_check_dependency (expr1, matrix_b, true)) 3891 return 0; 3892 3893 m_case = none; 3894 if (matrix_a->rank == 2) 3895 { 3896 if (transpose_a) 3897 { 3898 if (matrix_b->rank == 2 && !transpose_b) 3899 m_case = A2TB2; 3900 } 3901 else 3902 { 3903 if (matrix_b->rank == 1) 3904 m_case = A2B1; 3905 else /* matrix_b->rank == 2 */ 3906 { 3907 if (transpose_b) 3908 m_case = A2B2T; 3909 else 3910 m_case = A2B2; 3911 } 3912 } 3913 } 3914 else /* matrix_a->rank == 1 */ 3915 { 3916 if (matrix_b->rank == 2) 3917 { 3918 if (!transpose_b) 3919 m_case = A1B2; 3920 } 3921 } 3922 3923 if (m_case == none) 3924 return 0; 3925 3926 /* We only handle assignment to numeric or logical variables. */ 3927 switch(expr1->ts.type) 3928 { 3929 case BT_INTEGER: 3930 case BT_LOGICAL: 3931 case BT_REAL: 3932 case BT_COMPLEX: 3933 break; 3934 3935 default: 3936 return 0; 3937 } 3938 3939 ns = insert_block (); 3940 3941 /* Assign the type of the zero expression for initializing the resulting 3942 array, and the expression (+ and * for real, integer and complex; 3943 .and. and .or for logical. */ 3944 3945 switch(expr1->ts.type) 3946 { 3947 case BT_INTEGER: 3948 zero_e = gfc_get_int_expr (expr1->ts.kind, &expr1->where, 0); 3949 op_times = INTRINSIC_TIMES; 3950 op_plus = INTRINSIC_PLUS; 3951 break; 3952 3953 case BT_LOGICAL: 3954 op_times = INTRINSIC_AND; 3955 op_plus = INTRINSIC_OR; 3956 zero_e = gfc_get_logical_expr (expr1->ts.kind, &expr1->where, 3957 0); 3958 break; 3959 case BT_REAL: 3960 zero_e = gfc_get_constant_expr (BT_REAL, expr1->ts.kind, 3961 &expr1->where); 3962 mpfr_set_si (zero_e->value.real, 0, GFC_RND_MODE); 3963 op_times = INTRINSIC_TIMES; 3964 op_plus = INTRINSIC_PLUS; 3965 break; 3966 3967 case BT_COMPLEX: 3968 zero_e = gfc_get_constant_expr (BT_COMPLEX, expr1->ts.kind, 3969 &expr1->where); 3970 mpc_set_si_si (zero_e->value.complex, 0, 0, GFC_RND_MODE); 3971 op_times = INTRINSIC_TIMES; 3972 op_plus = INTRINSIC_PLUS; 3973 3974 break; 3975 3976 default: 3977 gcc_unreachable(); 3978 } 3979 3980 current_code = &ns->code; 3981 3982 /* Freeze the references, keeping track of how many temporary variables were 3983 created. */ 3984 n_vars = 0; 3985 freeze_references (matrix_a); 3986 freeze_references (matrix_b); 3987 freeze_references (expr1); 3988 3989 if (n_vars == 0) 3990 next_code_point = current_code; 3991 else 3992 { 3993 next_code_point = &ns->code; 3994 for (i=0; i<n_vars; i++) 3995 next_code_point = &(*next_code_point)->next; 3996 } 3997 3998 /* Take care of the inline flag. If the limit check evaluates to a 3999 constant, dead code elimination will eliminate the unneeded branch. */ 4000 4001 if (flag_inline_matmul_limit > 0 && matrix_a->rank == 2 4002 && matrix_b->rank == 2) 4003 { 4004 if_limit = inline_limit_check (matrix_a, matrix_b, 4005 flag_inline_matmul_limit); 4006 4007 /* Insert the original statement into the else branch. */ 4008 if_limit->block->block->next = co; 4009 co->next = NULL; 4010 4011 /* ... and the new ones go into the original one. */ 4012 *next_code_point = if_limit; 4013 next_code_point = &if_limit->block->next; 4014 } 4015 4016 zero_e->no_bounds_check = 1; 4017 4018 assign_zero = XCNEW (gfc_code); 4019 assign_zero->op = EXEC_ASSIGN; 4020 assign_zero->loc = co->loc; 4021 assign_zero->expr1 = gfc_copy_expr (expr1); 4022 assign_zero->expr1->no_bounds_check = 1; 4023 assign_zero->expr2 = zero_e; 4024 4025 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); 4026 4027 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 4028 { 4029 gfc_code *test; 4030 gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; 4031 4032 switch (m_case) 4033 { 4034 case A2B1: 4035 4036 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4037 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4038 test = runtime_error_ne (b1, a2, B_ERROR_1); 4039 *next_code_point = test; 4040 next_code_point = &test->next; 4041 4042 if (!realloc_c) 4043 { 4044 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4045 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4046 test = runtime_error_ne (c1, a1, C_ERROR_1); 4047 *next_code_point = test; 4048 next_code_point = &test->next; 4049 } 4050 break; 4051 4052 case A1B2: 4053 4054 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4055 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4056 test = runtime_error_ne (b1, a1, B_ERROR_1); 4057 *next_code_point = test; 4058 next_code_point = &test->next; 4059 4060 if (!realloc_c) 4061 { 4062 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4063 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4064 test = runtime_error_ne (c1, b2, C_ERROR_1); 4065 *next_code_point = test; 4066 next_code_point = &test->next; 4067 } 4068 break; 4069 4070 case A2B2: 4071 4072 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4073 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4074 test = runtime_error_ne (b1, a2, B_ERROR_1); 4075 *next_code_point = test; 4076 next_code_point = &test->next; 4077 4078 if (!realloc_c) 4079 { 4080 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4081 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4082 test = runtime_error_ne (c1, a1, C_ERROR_1); 4083 *next_code_point = test; 4084 next_code_point = &test->next; 4085 4086 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4087 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4088 test = runtime_error_ne (c2, b2, C_ERROR_2); 4089 *next_code_point = test; 4090 next_code_point = &test->next; 4091 } 4092 break; 4093 4094 case A2B2T: 4095 4096 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4097 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4098 /* matrix_b is transposed, hence dimension 1 for the error message. */ 4099 test = runtime_error_ne (b2, a2, B_ERROR_1); 4100 *next_code_point = test; 4101 next_code_point = &test->next; 4102 4103 if (!realloc_c) 4104 { 4105 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4106 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4107 test = runtime_error_ne (c1, a1, C_ERROR_1); 4108 *next_code_point = test; 4109 next_code_point = &test->next; 4110 4111 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4112 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4113 test = runtime_error_ne (c2, b1, C_ERROR_2); 4114 *next_code_point = test; 4115 next_code_point = &test->next; 4116 } 4117 break; 4118 4119 case A2TB2: 4120 4121 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4122 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4123 test = runtime_error_ne (b1, a1, B_ERROR_1); 4124 *next_code_point = test; 4125 next_code_point = &test->next; 4126 4127 if (!realloc_c) 4128 { 4129 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4130 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4131 test = runtime_error_ne (c1, a2, C_ERROR_1); 4132 *next_code_point = test; 4133 next_code_point = &test->next; 4134 4135 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4136 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4137 test = runtime_error_ne (c2, b2, C_ERROR_2); 4138 *next_code_point = test; 4139 next_code_point = &test->next; 4140 } 4141 break; 4142 4143 default: 4144 gcc_unreachable (); 4145 } 4146 } 4147 4148 /* Handle the reallocation, if needed. */ 4149 4150 if (realloc_c) 4151 { 4152 gfc_code *lhs_alloc; 4153 4154 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); 4155 4156 *next_code_point = lhs_alloc; 4157 next_code_point = &lhs_alloc->next; 4158 4159 } 4160 4161 *next_code_point = assign_zero; 4162 4163 zero = gfc_get_int_expr (gfc_index_integer_kind, &co->loc, 0); 4164 4165 assign_matmul = XCNEW (gfc_code); 4166 assign_matmul->op = EXEC_ASSIGN; 4167 assign_matmul->loc = co->loc; 4168 4169 /* Get the bounds for the loops, create them and create the scalarized 4170 expressions. */ 4171 4172 switch (m_case) 4173 { 4174 case A2B2: 4175 4176 u1 = get_size_m1 (matrix_b, 2); 4177 u2 = get_size_m1 (matrix_a, 2); 4178 u3 = get_size_m1 (matrix_a, 1); 4179 4180 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); 4181 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); 4182 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); 4183 4184 do_1->block->next = do_2; 4185 do_2->block->next = do_3; 4186 do_3->block->next = assign_matmul; 4187 4188 var_1 = do_1->ext.iterator->var; 4189 var_2 = do_2->ext.iterator->var; 4190 var_3 = do_3->ext.iterator->var; 4191 4192 list[0] = var_3; 4193 list[1] = var_1; 4194 cscalar = scalarized_expr (co->expr1, list, 2); 4195 4196 list[0] = var_3; 4197 list[1] = var_2; 4198 ascalar = scalarized_expr (matrix_a, list, 2); 4199 4200 list[0] = var_2; 4201 list[1] = var_1; 4202 bscalar = scalarized_expr (matrix_b, list, 2); 4203 4204 break; 4205 4206 case A2B2T: 4207 4208 u1 = get_size_m1 (matrix_b, 1); 4209 u2 = get_size_m1 (matrix_a, 2); 4210 u3 = get_size_m1 (matrix_a, 1); 4211 4212 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); 4213 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); 4214 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); 4215 4216 do_1->block->next = do_2; 4217 do_2->block->next = do_3; 4218 do_3->block->next = assign_matmul; 4219 4220 var_1 = do_1->ext.iterator->var; 4221 var_2 = do_2->ext.iterator->var; 4222 var_3 = do_3->ext.iterator->var; 4223 4224 list[0] = var_3; 4225 list[1] = var_1; 4226 cscalar = scalarized_expr (co->expr1, list, 2); 4227 4228 list[0] = var_3; 4229 list[1] = var_2; 4230 ascalar = scalarized_expr (matrix_a, list, 2); 4231 4232 list[0] = var_1; 4233 list[1] = var_2; 4234 bscalar = scalarized_expr (matrix_b, list, 2); 4235 4236 break; 4237 4238 case A2TB2: 4239 4240 u1 = get_size_m1 (matrix_a, 2); 4241 u2 = get_size_m1 (matrix_b, 2); 4242 u3 = get_size_m1 (matrix_a, 1); 4243 4244 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); 4245 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); 4246 do_3 = create_do_loop (gfc_copy_expr (zero), u3, NULL, &co->loc, ns); 4247 4248 do_1->block->next = do_2; 4249 do_2->block->next = do_3; 4250 do_3->block->next = assign_matmul; 4251 4252 var_1 = do_1->ext.iterator->var; 4253 var_2 = do_2->ext.iterator->var; 4254 var_3 = do_3->ext.iterator->var; 4255 4256 list[0] = var_1; 4257 list[1] = var_2; 4258 cscalar = scalarized_expr (co->expr1, list, 2); 4259 4260 list[0] = var_3; 4261 list[1] = var_1; 4262 ascalar = scalarized_expr (matrix_a, list, 2); 4263 4264 list[0] = var_3; 4265 list[1] = var_2; 4266 bscalar = scalarized_expr (matrix_b, list, 2); 4267 4268 break; 4269 4270 case A2B1: 4271 u1 = get_size_m1 (matrix_b, 1); 4272 u2 = get_size_m1 (matrix_a, 1); 4273 4274 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); 4275 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); 4276 4277 do_1->block->next = do_2; 4278 do_2->block->next = assign_matmul; 4279 4280 var_1 = do_1->ext.iterator->var; 4281 var_2 = do_2->ext.iterator->var; 4282 4283 list[0] = var_2; 4284 cscalar = scalarized_expr (co->expr1, list, 1); 4285 4286 list[0] = var_2; 4287 list[1] = var_1; 4288 ascalar = scalarized_expr (matrix_a, list, 2); 4289 4290 list[0] = var_1; 4291 bscalar = scalarized_expr (matrix_b, list, 1); 4292 4293 break; 4294 4295 case A1B2: 4296 u1 = get_size_m1 (matrix_b, 2); 4297 u2 = get_size_m1 (matrix_a, 1); 4298 4299 do_1 = create_do_loop (gfc_copy_expr (zero), u1, NULL, &co->loc, ns); 4300 do_2 = create_do_loop (gfc_copy_expr (zero), u2, NULL, &co->loc, ns); 4301 4302 do_1->block->next = do_2; 4303 do_2->block->next = assign_matmul; 4304 4305 var_1 = do_1->ext.iterator->var; 4306 var_2 = do_2->ext.iterator->var; 4307 4308 list[0] = var_1; 4309 cscalar = scalarized_expr (co->expr1, list, 1); 4310 4311 list[0] = var_2; 4312 ascalar = scalarized_expr (matrix_a, list, 1); 4313 4314 list[0] = var_2; 4315 list[1] = var_1; 4316 bscalar = scalarized_expr (matrix_b, list, 2); 4317 4318 break; 4319 4320 default: 4321 gcc_unreachable(); 4322 } 4323 4324 /* Build the conjg call around the variables. Set the typespec manually 4325 because gfc_build_intrinsic_call sometimes gets this wrong. */ 4326 if (conjg_a) 4327 { 4328 gfc_typespec ts; 4329 ts = matrix_a->ts; 4330 ascalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", 4331 matrix_a->where, 1, ascalar); 4332 ascalar->ts = ts; 4333 } 4334 4335 if (conjg_b) 4336 { 4337 gfc_typespec ts; 4338 ts = matrix_b->ts; 4339 bscalar = gfc_build_intrinsic_call (ns, GFC_ISYM_CONJG, "conjg", 4340 matrix_b->where, 1, bscalar); 4341 bscalar->ts = ts; 4342 } 4343 /* First loop comes after the zero assignment. */ 4344 assign_zero->next = do_1; 4345 4346 /* Build the assignment expression in the loop. */ 4347 assign_matmul->expr1 = gfc_copy_expr (cscalar); 4348 4349 mult = get_operand (op_times, ascalar, bscalar); 4350 assign_matmul->expr2 = get_operand (op_plus, cscalar, mult); 4351 4352 /* If we don't want to keep the original statement around in 4353 the else branch, we can free it. */ 4354 4355 if (if_limit == NULL) 4356 gfc_free_statements(co); 4357 else 4358 co->next = NULL; 4359 4360 gfc_free_expr (zero); 4361 *walk_subtrees = 0; 4362 return 0; 4363 } 4364 4365 /* Change matmul function calls in the form of 4366 4367 c = matmul(a,b) 4368 4369 to the corresponding call to a BLAS routine, if applicable. */ 4370 4371 static int 4372 call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 4373 void *data ATTRIBUTE_UNUSED) 4374 { 4375 gfc_code *co, *co_next; 4376 gfc_expr *expr1, *expr2; 4377 gfc_expr *matrix_a, *matrix_b; 4378 gfc_code *if_limit = NULL; 4379 gfc_actual_arglist *a, *b; 4380 bool conjg_a, conjg_b, transpose_a, transpose_b; 4381 gfc_code *call; 4382 const char *blas_name; 4383 const char *transa, *transb; 4384 gfc_expr *c1, *c2, *b1; 4385 gfc_actual_arglist *actual, *next; 4386 bt type; 4387 int kind; 4388 enum matrix_case m_case; 4389 bool realloc_c; 4390 gfc_code **next_code_point; 4391 4392 /* Many of the tests for inline matmul also apply here. */ 4393 4394 co = *c; 4395 4396 if (co->op != EXEC_ASSIGN) 4397 return 0; 4398 4399 if (in_where || in_assoc_list) 4400 return 0; 4401 4402 /* The BLOCKS generated for the temporary variables and FORALL don't 4403 mix. */ 4404 if (forall_level > 0) 4405 return 0; 4406 4407 /* For now don't do anything in OpenMP workshare, it confuses 4408 its translation, which expects only the allowed statements in there. */ 4409 4410 if (in_omp_workshare || in_omp_atomic) 4411 return 0; 4412 4413 expr1 = co->expr1; 4414 expr2 = co->expr2; 4415 if (expr2->expr_type != EXPR_FUNCTION 4416 || expr2->value.function.isym == NULL 4417 || expr2->value.function.isym->id != GFC_ISYM_MATMUL) 4418 return 0; 4419 4420 type = expr2->ts.type; 4421 kind = expr2->ts.kind; 4422 4423 /* Guard against recursion. */ 4424 4425 if (expr2->external_blas) 4426 return 0; 4427 4428 if (type != expr1->ts.type || kind != expr1->ts.kind) 4429 return 0; 4430 4431 if (type == BT_REAL) 4432 { 4433 if (kind == 4) 4434 blas_name = "sgemm"; 4435 else if (kind == 8) 4436 blas_name = "dgemm"; 4437 else 4438 return 0; 4439 } 4440 else if (type == BT_COMPLEX) 4441 { 4442 if (kind == 4) 4443 blas_name = "cgemm"; 4444 else if (kind == 8) 4445 blas_name = "zgemm"; 4446 else 4447 return 0; 4448 } 4449 else 4450 return 0; 4451 4452 a = expr2->value.function.actual; 4453 if (a->expr->rank != 2) 4454 return 0; 4455 4456 b = a->next; 4457 if (b->expr->rank != 2) 4458 return 0; 4459 4460 matrix_a = check_conjg_transpose_variable (a->expr, &conjg_a, &transpose_a); 4461 if (matrix_a == NULL) 4462 return 0; 4463 4464 if (transpose_a) 4465 { 4466 if (conjg_a) 4467 transa = "C"; 4468 else 4469 transa = "T"; 4470 } 4471 else 4472 transa = "N"; 4473 4474 matrix_b = check_conjg_transpose_variable (b->expr, &conjg_b, &transpose_b); 4475 if (matrix_b == NULL) 4476 return 0; 4477 4478 if (transpose_b) 4479 { 4480 if (conjg_b) 4481 transb = "C"; 4482 else 4483 transb = "T"; 4484 } 4485 else 4486 transb = "N"; 4487 4488 if (transpose_a) 4489 { 4490 if (transpose_b) 4491 m_case = A2TB2T; 4492 else 4493 m_case = A2TB2; 4494 } 4495 else 4496 { 4497 if (transpose_b) 4498 m_case = A2B2T; 4499 else 4500 m_case = A2B2; 4501 } 4502 4503 current_code = c; 4504 inserted_block = NULL; 4505 changed_statement = NULL; 4506 4507 expr2->external_blas = 1; 4508 4509 /* We do not handle data dependencies yet. */ 4510 if (gfc_check_dependency (expr1, matrix_a, true) 4511 || gfc_check_dependency (expr1, matrix_b, true)) 4512 return 0; 4513 4514 /* Generate the if statement and hang it into the tree. */ 4515 if_limit = inline_limit_check (matrix_a, matrix_b, flag_blas_matmul_limit); 4516 co_next = co->next; 4517 (*current_code) = if_limit; 4518 co->next = NULL; 4519 if_limit->block->next = co; 4520 4521 call = XCNEW (gfc_code); 4522 call->loc = co->loc; 4523 4524 /* Bounds checking - a bit simpler than for inlining since we only 4525 have to take care of two-dimensional arrays here. */ 4526 4527 realloc_c = flag_realloc_lhs && gfc_is_reallocatable_lhs (expr1); 4528 next_code_point = &(if_limit->block->block->next); 4529 4530 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 4531 { 4532 gfc_code *test; 4533 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2; 4534 gfc_expr *c1, *a1, *c2, *b2, *a2; 4535 switch (m_case) 4536 { 4537 case A2B2: 4538 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4539 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4540 test = runtime_error_ne (b1, a2, B_ERROR_1); 4541 *next_code_point = test; 4542 next_code_point = &test->next; 4543 4544 if (!realloc_c) 4545 { 4546 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4547 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4548 test = runtime_error_ne (c1, a1, C_ERROR_1); 4549 *next_code_point = test; 4550 next_code_point = &test->next; 4551 4552 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4553 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4554 test = runtime_error_ne (c2, b2, C_ERROR_2); 4555 *next_code_point = test; 4556 next_code_point = &test->next; 4557 } 4558 break; 4559 4560 case A2B2T: 4561 4562 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4563 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4564 /* matrix_b is transposed, hence dimension 1 for the error message. */ 4565 test = runtime_error_ne (b2, a2, B_ERROR_1); 4566 *next_code_point = test; 4567 next_code_point = &test->next; 4568 4569 if (!realloc_c) 4570 { 4571 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4572 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4573 test = runtime_error_ne (c1, a1, C_ERROR_1); 4574 *next_code_point = test; 4575 next_code_point = &test->next; 4576 4577 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4578 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4579 test = runtime_error_ne (c2, b1, C_ERROR_2); 4580 *next_code_point = test; 4581 next_code_point = &test->next; 4582 } 4583 break; 4584 4585 case A2TB2: 4586 4587 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4588 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4589 test = runtime_error_ne (b1, a1, B_ERROR_1); 4590 *next_code_point = test; 4591 next_code_point = &test->next; 4592 4593 if (!realloc_c) 4594 { 4595 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4596 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4597 test = runtime_error_ne (c1, a2, C_ERROR_1); 4598 *next_code_point = test; 4599 next_code_point = &test->next; 4600 4601 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4602 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4603 test = runtime_error_ne (c2, b2, C_ERROR_2); 4604 *next_code_point = test; 4605 next_code_point = &test->next; 4606 } 4607 break; 4608 4609 case A2TB2T: 4610 b2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 2); 4611 a1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 1); 4612 test = runtime_error_ne (b2, a1, B_ERROR_1); 4613 *next_code_point = test; 4614 next_code_point = &test->next; 4615 4616 if (!realloc_c) 4617 { 4618 c1 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 1); 4619 a2 = get_array_inq_function (GFC_ISYM_SIZE, matrix_a, 2); 4620 test = runtime_error_ne (c1, a2, C_ERROR_1); 4621 *next_code_point = test; 4622 next_code_point = &test->next; 4623 4624 c2 = get_array_inq_function (GFC_ISYM_SIZE, expr1, 2); 4625 b1 = get_array_inq_function (GFC_ISYM_SIZE, matrix_b, 1); 4626 test = runtime_error_ne (c2, b1, C_ERROR_2); 4627 *next_code_point = test; 4628 next_code_point = &test->next; 4629 } 4630 break; 4631 4632 default: 4633 gcc_unreachable (); 4634 } 4635 } 4636 4637 /* Handle the reallocation, if needed. */ 4638 4639 if (realloc_c) 4640 { 4641 gfc_code *lhs_alloc; 4642 4643 lhs_alloc = matmul_lhs_realloc (expr1, matrix_a, matrix_b, m_case); 4644 *next_code_point = lhs_alloc; 4645 next_code_point = &lhs_alloc->next; 4646 } 4647 4648 *next_code_point = call; 4649 if_limit->next = co_next; 4650 4651 /* Set up the BLAS call. */ 4652 4653 call->op = EXEC_CALL; 4654 4655 gfc_get_sym_tree (blas_name, current_ns, &(call->symtree), true); 4656 call->symtree->n.sym->attr.subroutine = 1; 4657 call->symtree->n.sym->attr.procedure = 1; 4658 call->symtree->n.sym->attr.flavor = FL_PROCEDURE; 4659 call->resolved_sym = call->symtree->n.sym; 4660 gfc_commit_symbol (call->resolved_sym); 4661 4662 /* Argument TRANSA. */ 4663 next = gfc_get_actual_arglist (); 4664 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, 4665 transa, 1); 4666 4667 call->ext.actual = next; 4668 4669 /* Argument TRANSB. */ 4670 actual = next; 4671 next = gfc_get_actual_arglist (); 4672 next->expr = gfc_get_character_expr (gfc_default_character_kind, &co->loc, 4673 transb, 1); 4674 actual->next = next; 4675 4676 c1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (a->expr), 1, 4677 gfc_integer_4_kind); 4678 c2 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 2, 4679 gfc_integer_4_kind); 4680 4681 b1 = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (b->expr), 1, 4682 gfc_integer_4_kind); 4683 4684 /* Argument M. */ 4685 actual = next; 4686 next = gfc_get_actual_arglist (); 4687 next->expr = c1; 4688 actual->next = next; 4689 4690 /* Argument N. */ 4691 actual = next; 4692 next = gfc_get_actual_arglist (); 4693 next->expr = c2; 4694 actual->next = next; 4695 4696 /* Argument K. */ 4697 actual = next; 4698 next = gfc_get_actual_arglist (); 4699 next->expr = b1; 4700 actual->next = next; 4701 4702 /* Argument ALPHA - set to one. */ 4703 actual = next; 4704 next = gfc_get_actual_arglist (); 4705 next->expr = gfc_get_constant_expr (type, kind, &co->loc); 4706 if (type == BT_REAL) 4707 mpfr_set_ui (next->expr->value.real, 1, GFC_RND_MODE); 4708 else 4709 mpc_set_ui (next->expr->value.complex, 1, GFC_MPC_RND_MODE); 4710 actual->next = next; 4711 4712 /* Argument A. */ 4713 actual = next; 4714 next = gfc_get_actual_arglist (); 4715 next->expr = gfc_copy_expr (matrix_a); 4716 actual->next = next; 4717 4718 /* Argument LDA. */ 4719 actual = next; 4720 next = gfc_get_actual_arglist (); 4721 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_a), 4722 1, gfc_integer_4_kind); 4723 actual->next = next; 4724 4725 /* Argument B. */ 4726 actual = next; 4727 next = gfc_get_actual_arglist (); 4728 next->expr = gfc_copy_expr (matrix_b); 4729 actual->next = next; 4730 4731 /* Argument LDB. */ 4732 actual = next; 4733 next = gfc_get_actual_arglist (); 4734 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (matrix_b), 4735 1, gfc_integer_4_kind); 4736 actual->next = next; 4737 4738 /* Argument BETA - set to zero. */ 4739 actual = next; 4740 next = gfc_get_actual_arglist (); 4741 next->expr = gfc_get_constant_expr (type, kind, &co->loc); 4742 if (type == BT_REAL) 4743 mpfr_set_ui (next->expr->value.real, 0, GFC_RND_MODE); 4744 else 4745 mpc_set_ui (next->expr->value.complex, 0, GFC_MPC_RND_MODE); 4746 actual->next = next; 4747 4748 /* Argument C. */ 4749 4750 actual = next; 4751 next = gfc_get_actual_arglist (); 4752 next->expr = gfc_copy_expr (expr1); 4753 actual->next = next; 4754 4755 /* Argument LDC. */ 4756 actual = next; 4757 next = gfc_get_actual_arglist (); 4758 next->expr = get_array_inq_function (GFC_ISYM_SIZE, gfc_copy_expr (expr1), 4759 1, gfc_integer_4_kind); 4760 actual->next = next; 4761 4762 return 0; 4763 } 4764 4765 4766 /* Code for index interchange for loops which are grouped together in DO 4767 CONCURRENT or FORALL statements. This is currently only applied if the 4768 iterations are grouped together in a single statement. 4769 4770 For this transformation, it is assumed that memory access in strides is 4771 expensive, and that loops which access later indices (which access memory 4772 in bigger strides) should be moved to the first loops. 4773 4774 For this, a loop over all the statements is executed, counting the times 4775 that the loop iteration values are accessed in each index. The loop 4776 indices are then sorted to minimize access to later indices from inner 4777 loops. */ 4778 4779 /* Type for holding index information. */ 4780 4781 typedef struct { 4782 gfc_symbol *sym; 4783 gfc_forall_iterator *fa; 4784 int num; 4785 int n[GFC_MAX_DIMENSIONS]; 4786 } ind_type; 4787 4788 /* Callback function to determine if an expression is the 4789 corresponding variable. */ 4790 4791 static int 4792 has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) 4793 { 4794 gfc_expr *expr = *e; 4795 gfc_symbol *sym; 4796 4797 if (expr->expr_type != EXPR_VARIABLE) 4798 return 0; 4799 4800 sym = (gfc_symbol *) data; 4801 return sym == expr->symtree->n.sym; 4802 } 4803 4804 /* Callback function to calculate the cost of a certain index. */ 4805 4806 static int 4807 index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 4808 void *data) 4809 { 4810 ind_type *ind; 4811 gfc_expr *expr; 4812 gfc_array_ref *ar; 4813 gfc_ref *ref; 4814 int i,j; 4815 4816 expr = *e; 4817 if (expr->expr_type != EXPR_VARIABLE) 4818 return 0; 4819 4820 ar = NULL; 4821 for (ref = expr->ref; ref; ref = ref->next) 4822 { 4823 if (ref->type == REF_ARRAY) 4824 { 4825 ar = &ref->u.ar; 4826 break; 4827 } 4828 } 4829 if (ar == NULL || ar->type != AR_ELEMENT) 4830 return 0; 4831 4832 ind = (ind_type *) data; 4833 for (i = 0; i < ar->dimen; i++) 4834 { 4835 for (j=0; ind[j].sym != NULL; j++) 4836 { 4837 if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym))) 4838 ind[j].n[i]++; 4839 } 4840 } 4841 return 0; 4842 } 4843 4844 /* Callback function for qsort, to sort the loop indices. */ 4845 4846 static int 4847 loop_comp (const void *e1, const void *e2) 4848 { 4849 const ind_type *i1 = (const ind_type *) e1; 4850 const ind_type *i2 = (const ind_type *) e2; 4851 int i; 4852 4853 for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--) 4854 { 4855 if (i1->n[i] != i2->n[i]) 4856 return i1->n[i] - i2->n[i]; 4857 } 4858 /* All other things being equal, let's not change the ordering. */ 4859 return i2->num - i1->num; 4860 } 4861 4862 /* Main function to do the index interchange. */ 4863 4864 static int 4865 index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 4866 void *data ATTRIBUTE_UNUSED) 4867 { 4868 gfc_code *co; 4869 co = *c; 4870 int n_iter; 4871 gfc_forall_iterator *fa; 4872 ind_type *ind; 4873 int i, j; 4874 4875 if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT) 4876 return 0; 4877 4878 n_iter = 0; 4879 for (fa = co->ext.forall_iterator; fa; fa = fa->next) 4880 n_iter ++; 4881 4882 /* Nothing to reorder. */ 4883 if (n_iter < 2) 4884 return 0; 4885 4886 ind = XALLOCAVEC (ind_type, n_iter + 1); 4887 4888 i = 0; 4889 for (fa = co->ext.forall_iterator; fa; fa = fa->next) 4890 { 4891 ind[i].sym = fa->var->symtree->n.sym; 4892 ind[i].fa = fa; 4893 for (j=0; j<GFC_MAX_DIMENSIONS; j++) 4894 ind[i].n[j] = 0; 4895 ind[i].num = i; 4896 i++; 4897 } 4898 ind[n_iter].sym = NULL; 4899 ind[n_iter].fa = NULL; 4900 4901 gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind); 4902 qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp); 4903 4904 /* Do the actual index interchange. */ 4905 co->ext.forall_iterator = fa = ind[0].fa; 4906 for (i=1; i<n_iter; i++) 4907 { 4908 fa->next = ind[i].fa; 4909 fa = fa->next; 4910 } 4911 fa->next = NULL; 4912 4913 if (flag_warn_frontend_loop_interchange) 4914 { 4915 for (i=1; i<n_iter; i++) 4916 { 4917 if (ind[i-1].num > ind[i].num) 4918 { 4919 gfc_warning (OPT_Wfrontend_loop_interchange, 4920 "Interchanging loops at %L", &co->loc); 4921 break; 4922 } 4923 } 4924 } 4925 4926 return 0; 4927 } 4928 4929 #define WALK_SUBEXPR(NODE) \ 4930 do \ 4931 { \ 4932 result = gfc_expr_walker (&(NODE), exprfn, data); \ 4933 if (result) \ 4934 return result; \ 4935 } \ 4936 while (0) 4937 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue 4938 4939 /* Walk expression *E, calling EXPRFN on each expression in it. */ 4940 4941 int 4942 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) 4943 { 4944 while (*e) 4945 { 4946 int walk_subtrees = 1; 4947 gfc_actual_arglist *a; 4948 gfc_ref *r; 4949 gfc_constructor *c; 4950 4951 int result = exprfn (e, &walk_subtrees, data); 4952 if (result) 4953 return result; 4954 if (walk_subtrees) 4955 switch ((*e)->expr_type) 4956 { 4957 case EXPR_OP: 4958 WALK_SUBEXPR ((*e)->value.op.op1); 4959 WALK_SUBEXPR_TAIL ((*e)->value.op.op2); 4960 break; 4961 case EXPR_FUNCTION: 4962 for (a = (*e)->value.function.actual; a; a = a->next) 4963 WALK_SUBEXPR (a->expr); 4964 break; 4965 case EXPR_COMPCALL: 4966 case EXPR_PPC: 4967 WALK_SUBEXPR ((*e)->value.compcall.base_object); 4968 for (a = (*e)->value.compcall.actual; a; a = a->next) 4969 WALK_SUBEXPR (a->expr); 4970 break; 4971 4972 case EXPR_STRUCTURE: 4973 case EXPR_ARRAY: 4974 for (c = gfc_constructor_first ((*e)->value.constructor); c; 4975 c = gfc_constructor_next (c)) 4976 { 4977 if (c->iterator == NULL) 4978 WALK_SUBEXPR (c->expr); 4979 else 4980 { 4981 iterator_level ++; 4982 WALK_SUBEXPR (c->expr); 4983 iterator_level --; 4984 WALK_SUBEXPR (c->iterator->var); 4985 WALK_SUBEXPR (c->iterator->start); 4986 WALK_SUBEXPR (c->iterator->end); 4987 WALK_SUBEXPR (c->iterator->step); 4988 } 4989 } 4990 4991 if ((*e)->expr_type != EXPR_ARRAY) 4992 break; 4993 4994 /* Fall through to the variable case in order to walk the 4995 reference. */ 4996 gcc_fallthrough (); 4997 4998 case EXPR_SUBSTRING: 4999 case EXPR_VARIABLE: 5000 for (r = (*e)->ref; r; r = r->next) 5001 { 5002 gfc_array_ref *ar; 5003 int i; 5004 5005 switch (r->type) 5006 { 5007 case REF_ARRAY: 5008 ar = &r->u.ar; 5009 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) 5010 { 5011 for (i=0; i< ar->dimen; i++) 5012 { 5013 WALK_SUBEXPR (ar->start[i]); 5014 WALK_SUBEXPR (ar->end[i]); 5015 WALK_SUBEXPR (ar->stride[i]); 5016 } 5017 } 5018 5019 break; 5020 5021 case REF_SUBSTRING: 5022 WALK_SUBEXPR (r->u.ss.start); 5023 WALK_SUBEXPR (r->u.ss.end); 5024 break; 5025 5026 case REF_COMPONENT: 5027 case REF_INQUIRY: 5028 break; 5029 } 5030 } 5031 5032 default: 5033 break; 5034 } 5035 return 0; 5036 } 5037 return 0; 5038 } 5039 5040 #define WALK_SUBCODE(NODE) \ 5041 do \ 5042 { \ 5043 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ 5044 if (result) \ 5045 return result; \ 5046 } \ 5047 while (0) 5048 5049 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN 5050 on each expression in it. If any of the hooks returns non-zero, that 5051 value is immediately returned. If the hook sets *WALK_SUBTREES to 0, 5052 no subcodes or subexpressions are traversed. */ 5053 5054 int 5055 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, 5056 void *data) 5057 { 5058 for (; *c; c = &(*c)->next) 5059 { 5060 int walk_subtrees = 1; 5061 int result = codefn (c, &walk_subtrees, data); 5062 if (result) 5063 return result; 5064 5065 if (walk_subtrees) 5066 { 5067 gfc_code *b; 5068 gfc_actual_arglist *a; 5069 gfc_code *co; 5070 gfc_association_list *alist; 5071 bool saved_in_omp_workshare; 5072 bool saved_in_omp_atomic; 5073 bool saved_in_where; 5074 5075 /* There might be statement insertions before the current code, 5076 which must not affect the expression walker. */ 5077 5078 co = *c; 5079 saved_in_omp_workshare = in_omp_workshare; 5080 saved_in_omp_atomic = in_omp_atomic; 5081 saved_in_where = in_where; 5082 5083 switch (co->op) 5084 { 5085 5086 case EXEC_BLOCK: 5087 WALK_SUBCODE (co->ext.block.ns->code); 5088 if (co->ext.block.assoc) 5089 { 5090 bool saved_in_assoc_list = in_assoc_list; 5091 5092 in_assoc_list = true; 5093 for (alist = co->ext.block.assoc; alist; alist = alist->next) 5094 WALK_SUBEXPR (alist->target); 5095 5096 in_assoc_list = saved_in_assoc_list; 5097 } 5098 5099 break; 5100 5101 case EXEC_DO: 5102 doloop_level ++; 5103 WALK_SUBEXPR (co->ext.iterator->var); 5104 WALK_SUBEXPR (co->ext.iterator->start); 5105 WALK_SUBEXPR (co->ext.iterator->end); 5106 WALK_SUBEXPR (co->ext.iterator->step); 5107 break; 5108 5109 case EXEC_IF: 5110 if_level ++; 5111 break; 5112 5113 case EXEC_WHERE: 5114 in_where = true; 5115 break; 5116 5117 case EXEC_CALL: 5118 case EXEC_ASSIGN_CALL: 5119 for (a = co->ext.actual; a; a = a->next) 5120 WALK_SUBEXPR (a->expr); 5121 break; 5122 5123 case EXEC_CALL_PPC: 5124 WALK_SUBEXPR (co->expr1); 5125 for (a = co->ext.actual; a; a = a->next) 5126 WALK_SUBEXPR (a->expr); 5127 break; 5128 5129 case EXEC_SELECT: 5130 WALK_SUBEXPR (co->expr1); 5131 select_level ++; 5132 for (b = co->block; b; b = b->block) 5133 { 5134 gfc_case *cp; 5135 for (cp = b->ext.block.case_list; cp; cp = cp->next) 5136 { 5137 WALK_SUBEXPR (cp->low); 5138 WALK_SUBEXPR (cp->high); 5139 } 5140 WALK_SUBCODE (b->next); 5141 } 5142 continue; 5143 5144 case EXEC_ALLOCATE: 5145 case EXEC_DEALLOCATE: 5146 { 5147 gfc_alloc *a; 5148 for (a = co->ext.alloc.list; a; a = a->next) 5149 WALK_SUBEXPR (a->expr); 5150 break; 5151 } 5152 5153 case EXEC_FORALL: 5154 case EXEC_DO_CONCURRENT: 5155 { 5156 gfc_forall_iterator *fa; 5157 for (fa = co->ext.forall_iterator; fa; fa = fa->next) 5158 { 5159 WALK_SUBEXPR (fa->var); 5160 WALK_SUBEXPR (fa->start); 5161 WALK_SUBEXPR (fa->end); 5162 WALK_SUBEXPR (fa->stride); 5163 } 5164 if (co->op == EXEC_FORALL) 5165 forall_level ++; 5166 break; 5167 } 5168 5169 case EXEC_OPEN: 5170 WALK_SUBEXPR (co->ext.open->unit); 5171 WALK_SUBEXPR (co->ext.open->file); 5172 WALK_SUBEXPR (co->ext.open->status); 5173 WALK_SUBEXPR (co->ext.open->access); 5174 WALK_SUBEXPR (co->ext.open->form); 5175 WALK_SUBEXPR (co->ext.open->recl); 5176 WALK_SUBEXPR (co->ext.open->blank); 5177 WALK_SUBEXPR (co->ext.open->position); 5178 WALK_SUBEXPR (co->ext.open->action); 5179 WALK_SUBEXPR (co->ext.open->delim); 5180 WALK_SUBEXPR (co->ext.open->pad); 5181 WALK_SUBEXPR (co->ext.open->iostat); 5182 WALK_SUBEXPR (co->ext.open->iomsg); 5183 WALK_SUBEXPR (co->ext.open->convert); 5184 WALK_SUBEXPR (co->ext.open->decimal); 5185 WALK_SUBEXPR (co->ext.open->encoding); 5186 WALK_SUBEXPR (co->ext.open->round); 5187 WALK_SUBEXPR (co->ext.open->sign); 5188 WALK_SUBEXPR (co->ext.open->asynchronous); 5189 WALK_SUBEXPR (co->ext.open->id); 5190 WALK_SUBEXPR (co->ext.open->newunit); 5191 WALK_SUBEXPR (co->ext.open->share); 5192 WALK_SUBEXPR (co->ext.open->cc); 5193 break; 5194 5195 case EXEC_CLOSE: 5196 WALK_SUBEXPR (co->ext.close->unit); 5197 WALK_SUBEXPR (co->ext.close->status); 5198 WALK_SUBEXPR (co->ext.close->iostat); 5199 WALK_SUBEXPR (co->ext.close->iomsg); 5200 break; 5201 5202 case EXEC_BACKSPACE: 5203 case EXEC_ENDFILE: 5204 case EXEC_REWIND: 5205 case EXEC_FLUSH: 5206 WALK_SUBEXPR (co->ext.filepos->unit); 5207 WALK_SUBEXPR (co->ext.filepos->iostat); 5208 WALK_SUBEXPR (co->ext.filepos->iomsg); 5209 break; 5210 5211 case EXEC_INQUIRE: 5212 WALK_SUBEXPR (co->ext.inquire->unit); 5213 WALK_SUBEXPR (co->ext.inquire->file); 5214 WALK_SUBEXPR (co->ext.inquire->iomsg); 5215 WALK_SUBEXPR (co->ext.inquire->iostat); 5216 WALK_SUBEXPR (co->ext.inquire->exist); 5217 WALK_SUBEXPR (co->ext.inquire->opened); 5218 WALK_SUBEXPR (co->ext.inquire->number); 5219 WALK_SUBEXPR (co->ext.inquire->named); 5220 WALK_SUBEXPR (co->ext.inquire->name); 5221 WALK_SUBEXPR (co->ext.inquire->access); 5222 WALK_SUBEXPR (co->ext.inquire->sequential); 5223 WALK_SUBEXPR (co->ext.inquire->direct); 5224 WALK_SUBEXPR (co->ext.inquire->form); 5225 WALK_SUBEXPR (co->ext.inquire->formatted); 5226 WALK_SUBEXPR (co->ext.inquire->unformatted); 5227 WALK_SUBEXPR (co->ext.inquire->recl); 5228 WALK_SUBEXPR (co->ext.inquire->nextrec); 5229 WALK_SUBEXPR (co->ext.inquire->blank); 5230 WALK_SUBEXPR (co->ext.inquire->position); 5231 WALK_SUBEXPR (co->ext.inquire->action); 5232 WALK_SUBEXPR (co->ext.inquire->read); 5233 WALK_SUBEXPR (co->ext.inquire->write); 5234 WALK_SUBEXPR (co->ext.inquire->readwrite); 5235 WALK_SUBEXPR (co->ext.inquire->delim); 5236 WALK_SUBEXPR (co->ext.inquire->encoding); 5237 WALK_SUBEXPR (co->ext.inquire->pad); 5238 WALK_SUBEXPR (co->ext.inquire->iolength); 5239 WALK_SUBEXPR (co->ext.inquire->convert); 5240 WALK_SUBEXPR (co->ext.inquire->strm_pos); 5241 WALK_SUBEXPR (co->ext.inquire->asynchronous); 5242 WALK_SUBEXPR (co->ext.inquire->decimal); 5243 WALK_SUBEXPR (co->ext.inquire->pending); 5244 WALK_SUBEXPR (co->ext.inquire->id); 5245 WALK_SUBEXPR (co->ext.inquire->sign); 5246 WALK_SUBEXPR (co->ext.inquire->size); 5247 WALK_SUBEXPR (co->ext.inquire->round); 5248 break; 5249 5250 case EXEC_WAIT: 5251 WALK_SUBEXPR (co->ext.wait->unit); 5252 WALK_SUBEXPR (co->ext.wait->iostat); 5253 WALK_SUBEXPR (co->ext.wait->iomsg); 5254 WALK_SUBEXPR (co->ext.wait->id); 5255 break; 5256 5257 case EXEC_READ: 5258 case EXEC_WRITE: 5259 WALK_SUBEXPR (co->ext.dt->io_unit); 5260 WALK_SUBEXPR (co->ext.dt->format_expr); 5261 WALK_SUBEXPR (co->ext.dt->rec); 5262 WALK_SUBEXPR (co->ext.dt->advance); 5263 WALK_SUBEXPR (co->ext.dt->iostat); 5264 WALK_SUBEXPR (co->ext.dt->size); 5265 WALK_SUBEXPR (co->ext.dt->iomsg); 5266 WALK_SUBEXPR (co->ext.dt->id); 5267 WALK_SUBEXPR (co->ext.dt->pos); 5268 WALK_SUBEXPR (co->ext.dt->asynchronous); 5269 WALK_SUBEXPR (co->ext.dt->blank); 5270 WALK_SUBEXPR (co->ext.dt->decimal); 5271 WALK_SUBEXPR (co->ext.dt->delim); 5272 WALK_SUBEXPR (co->ext.dt->pad); 5273 WALK_SUBEXPR (co->ext.dt->round); 5274 WALK_SUBEXPR (co->ext.dt->sign); 5275 WALK_SUBEXPR (co->ext.dt->extra_comma); 5276 break; 5277 5278 case EXEC_OACC_ATOMIC: 5279 case EXEC_OMP_ATOMIC: 5280 in_omp_atomic = true; 5281 break; 5282 5283 case EXEC_OMP_PARALLEL: 5284 case EXEC_OMP_PARALLEL_DO: 5285 case EXEC_OMP_PARALLEL_DO_SIMD: 5286 case EXEC_OMP_PARALLEL_SECTIONS: 5287 5288 in_omp_workshare = false; 5289 5290 /* This goto serves as a shortcut to avoid code 5291 duplication or a larger if or switch statement. */ 5292 goto check_omp_clauses; 5293 5294 case EXEC_OMP_WORKSHARE: 5295 case EXEC_OMP_PARALLEL_WORKSHARE: 5296 5297 in_omp_workshare = true; 5298 5299 /* Fall through */ 5300 5301 case EXEC_OMP_CRITICAL: 5302 case EXEC_OMP_DISTRIBUTE: 5303 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 5304 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 5305 case EXEC_OMP_DISTRIBUTE_SIMD: 5306 case EXEC_OMP_DO: 5307 case EXEC_OMP_DO_SIMD: 5308 case EXEC_OMP_ORDERED: 5309 case EXEC_OMP_SECTIONS: 5310 case EXEC_OMP_SINGLE: 5311 case EXEC_OMP_END_SINGLE: 5312 case EXEC_OMP_SIMD: 5313 case EXEC_OMP_TASKLOOP: 5314 case EXEC_OMP_TASKLOOP_SIMD: 5315 case EXEC_OMP_TARGET: 5316 case EXEC_OMP_TARGET_DATA: 5317 case EXEC_OMP_TARGET_ENTER_DATA: 5318 case EXEC_OMP_TARGET_EXIT_DATA: 5319 case EXEC_OMP_TARGET_PARALLEL: 5320 case EXEC_OMP_TARGET_PARALLEL_DO: 5321 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 5322 case EXEC_OMP_TARGET_SIMD: 5323 case EXEC_OMP_TARGET_TEAMS: 5324 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 5325 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 5326 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5327 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 5328 case EXEC_OMP_TARGET_UPDATE: 5329 case EXEC_OMP_TASK: 5330 case EXEC_OMP_TEAMS: 5331 case EXEC_OMP_TEAMS_DISTRIBUTE: 5332 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 5333 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 5334 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 5335 5336 /* Come to this label only from the 5337 EXEC_OMP_PARALLEL_* cases above. */ 5338 5339 check_omp_clauses: 5340 5341 if (co->ext.omp_clauses) 5342 { 5343 gfc_omp_namelist *n; 5344 static int list_types[] 5345 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, 5346 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM }; 5347 size_t idx; 5348 WALK_SUBEXPR (co->ext.omp_clauses->if_expr); 5349 WALK_SUBEXPR (co->ext.omp_clauses->final_expr); 5350 WALK_SUBEXPR (co->ext.omp_clauses->num_threads); 5351 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); 5352 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr); 5353 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr); 5354 WALK_SUBEXPR (co->ext.omp_clauses->num_teams); 5355 WALK_SUBEXPR (co->ext.omp_clauses->device); 5356 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit); 5357 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size); 5358 WALK_SUBEXPR (co->ext.omp_clauses->grainsize); 5359 WALK_SUBEXPR (co->ext.omp_clauses->hint); 5360 WALK_SUBEXPR (co->ext.omp_clauses->num_tasks); 5361 WALK_SUBEXPR (co->ext.omp_clauses->priority); 5362 for (idx = 0; idx < OMP_IF_LAST; idx++) 5363 WALK_SUBEXPR (co->ext.omp_clauses->if_exprs[idx]); 5364 for (idx = 0; 5365 idx < sizeof (list_types) / sizeof (list_types[0]); 5366 idx++) 5367 for (n = co->ext.omp_clauses->lists[list_types[idx]]; 5368 n; n = n->next) 5369 WALK_SUBEXPR (n->expr); 5370 } 5371 break; 5372 default: 5373 break; 5374 } 5375 5376 WALK_SUBEXPR (co->expr1); 5377 WALK_SUBEXPR (co->expr2); 5378 WALK_SUBEXPR (co->expr3); 5379 WALK_SUBEXPR (co->expr4); 5380 for (b = co->block; b; b = b->block) 5381 { 5382 WALK_SUBEXPR (b->expr1); 5383 WALK_SUBEXPR (b->expr2); 5384 WALK_SUBCODE (b->next); 5385 } 5386 5387 if (co->op == EXEC_FORALL) 5388 forall_level --; 5389 5390 if (co->op == EXEC_DO) 5391 doloop_level --; 5392 5393 if (co->op == EXEC_IF) 5394 if_level --; 5395 5396 if (co->op == EXEC_SELECT) 5397 select_level --; 5398 5399 in_omp_workshare = saved_in_omp_workshare; 5400 in_omp_atomic = saved_in_omp_atomic; 5401 in_where = saved_in_where; 5402 } 5403 } 5404 return 0; 5405 } 5406 5407 /* As a post-resolution step, check that all global symbols which are 5408 not declared in the source file match in their call signatures. 5409 We do this by looping over the code (and expressions). The first call 5410 we happen to find is assumed to be canonical. */ 5411 5412 5413 /* Common tests for argument checking for both functions and subroutines. */ 5414 5415 static int 5416 check_externals_procedure (gfc_symbol *sym, locus *loc, 5417 gfc_actual_arglist *actual) 5418 { 5419 gfc_gsymbol *gsym; 5420 gfc_symbol *def_sym = NULL; 5421 5422 if (sym == NULL || sym->attr.is_bind_c) 5423 return 0; 5424 5425 if (sym->attr.proc != PROC_EXTERNAL && sym->attr.proc != PROC_UNKNOWN) 5426 return 0; 5427 5428 if (sym->attr.if_source == IFSRC_IFBODY || sym->attr.if_source == IFSRC_DECL) 5429 return 0; 5430 5431 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); 5432 if (gsym == NULL) 5433 return 0; 5434 5435 if (gsym->ns) 5436 gfc_find_symbol (sym->name, gsym->ns, 0, &def_sym); 5437 5438 if (def_sym) 5439 { 5440 gfc_compare_actual_formal (&actual, def_sym->formal, 0, 0, 0, loc); 5441 return 0; 5442 } 5443 5444 /* First time we have seen this procedure called. Let's create an 5445 "interface" from the call and put it into a new namespace. */ 5446 gfc_namespace *save_ns; 5447 gfc_symbol *new_sym; 5448 5449 gsym->where = *loc; 5450 save_ns = gfc_current_ns; 5451 gsym->ns = gfc_get_namespace (gfc_current_ns, 0); 5452 gsym->ns->proc_name = sym; 5453 5454 gfc_get_symbol (sym->name, gsym->ns, &new_sym); 5455 gcc_assert (new_sym); 5456 new_sym->attr = sym->attr; 5457 new_sym->attr.if_source = IFSRC_DECL; 5458 gfc_current_ns = gsym->ns; 5459 5460 gfc_get_formal_from_actual_arglist (new_sym, actual); 5461 gfc_current_ns = save_ns; 5462 5463 return 0; 5464 5465 } 5466 5467 /* Callback for calls of external routines. */ 5468 5469 static int 5470 check_externals_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 5471 void *data ATTRIBUTE_UNUSED) 5472 { 5473 gfc_code *co = *c; 5474 gfc_symbol *sym; 5475 locus *loc; 5476 gfc_actual_arglist *actual; 5477 5478 if (co->op != EXEC_CALL) 5479 return 0; 5480 5481 sym = co->resolved_sym; 5482 loc = &co->loc; 5483 actual = co->ext.actual; 5484 5485 return check_externals_procedure (sym, loc, actual); 5486 5487 } 5488 5489 /* Callback for external functions. */ 5490 5491 static int 5492 check_externals_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED, 5493 void *data ATTRIBUTE_UNUSED) 5494 { 5495 gfc_expr *e = *ep; 5496 gfc_symbol *sym; 5497 locus *loc; 5498 gfc_actual_arglist *actual; 5499 5500 if (e->expr_type != EXPR_FUNCTION) 5501 return 0; 5502 5503 sym = e->value.function.esym; 5504 if (sym == NULL) 5505 return 0; 5506 5507 loc = &e->where; 5508 actual = e->value.function.actual; 5509 5510 return check_externals_procedure (sym, loc, actual); 5511 } 5512 5513 /* Called routine. */ 5514 5515 void 5516 gfc_check_externals (gfc_namespace *ns) 5517 { 5518 5519 gfc_clear_error (); 5520 5521 /* Turn errors into warnings if the user indicated this. */ 5522 5523 if (!pedantic && flag_allow_argument_mismatch) 5524 gfc_errors_to_warnings (true); 5525 5526 gfc_code_walker (&ns->code, check_externals_code, check_externals_expr, NULL); 5527 5528 for (ns = ns->contained; ns; ns = ns->sibling) 5529 { 5530 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 5531 gfc_check_externals (ns); 5532 } 5533 5534 gfc_errors_to_warnings (false); 5535 } 5536 5537 /* Callback function. If there is a call to a subroutine which is 5538 neither pure nor implicit_pure, unset the implicit_pure flag for 5539 the caller and return -1. */ 5540 5541 static int 5542 implicit_pure_call (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 5543 void *sym_data) 5544 { 5545 gfc_code *co = *c; 5546 gfc_symbol *caller_sym; 5547 symbol_attribute *a; 5548 5549 if (co->op != EXEC_CALL || co->resolved_sym == NULL) 5550 return 0; 5551 5552 a = &co->resolved_sym->attr; 5553 if (a->intrinsic || a->pure || a->implicit_pure) 5554 return 0; 5555 5556 caller_sym = (gfc_symbol *) sym_data; 5557 gfc_unset_implicit_pure (caller_sym); 5558 return 1; 5559 } 5560 5561 /* Callback function. If there is a call to a function which is 5562 neither pure nor implicit_pure, unset the implicit_pure flag for 5563 the caller and return 1. */ 5564 5565 static int 5566 implicit_pure_expr (gfc_expr **e, int *walk ATTRIBUTE_UNUSED, void *sym_data) 5567 { 5568 gfc_expr *expr = *e; 5569 gfc_symbol *caller_sym; 5570 gfc_symbol *sym; 5571 symbol_attribute *a; 5572 5573 if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym) 5574 return 0; 5575 5576 sym = expr->symtree->n.sym; 5577 a = &sym->attr; 5578 if (a->pure || a->implicit_pure) 5579 return 0; 5580 5581 caller_sym = (gfc_symbol *) sym_data; 5582 gfc_unset_implicit_pure (caller_sym); 5583 return 1; 5584 } 5585 5586 /* Go through all procedures in the namespace and unset the 5587 implicit_pure attribute for any procedure that calls something not 5588 pure or implicit pure. */ 5589 5590 bool 5591 gfc_fix_implicit_pure (gfc_namespace *ns) 5592 { 5593 bool changed = false; 5594 gfc_symbol *proc = ns->proc_name; 5595 5596 if (proc && proc->attr.flavor == FL_PROCEDURE && proc->attr.implicit_pure 5597 && ns->code 5598 && gfc_code_walker (&ns->code, implicit_pure_call, implicit_pure_expr, 5599 (void *) ns->proc_name)) 5600 changed = true; 5601 5602 for (ns = ns->contained; ns; ns = ns->sibling) 5603 { 5604 if (gfc_fix_implicit_pure (ns)) 5605 changed = true; 5606 } 5607 5608 return changed; 5609 } 5610