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