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