1/* Pass manager for Fortran front end. 2 Copyright (C) 2010-2015 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 "gfortran.h" 25#include "arith.h" 26#include "flags.h" 27#include "dependency.h" 28#include "constructor.h" 29#include "opts.h" 30 31/* Forward declarations. */ 32 33static void strip_function_call (gfc_expr *); 34static void optimize_namespace (gfc_namespace *); 35static void optimize_assignment (gfc_code *); 36static bool optimize_op (gfc_expr *); 37static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op); 38static bool optimize_trim (gfc_expr *); 39static bool optimize_lexical_comparison (gfc_expr *); 40static void optimize_minmaxloc (gfc_expr **); 41static bool is_empty_string (gfc_expr *e); 42static void doloop_warn (gfc_namespace *); 43static void optimize_reduction (gfc_namespace *); 44static int callback_reduction (gfc_expr **, int *, void *); 45static void realloc_strings (gfc_namespace *); 46static gfc_expr *create_var (gfc_expr *); 47 48/* How deep we are inside an argument list. */ 49 50static int count_arglist; 51 52/* Vector of gfc_expr ** we operate on. */ 53 54static vec<gfc_expr **> expr_array; 55 56/* Pointer to the gfc_code we currently work on - to be able to insert 57 a block before the statement. */ 58 59static gfc_code **current_code; 60 61/* Pointer to the block to be inserted, and the statement we are 62 changing within the block. */ 63 64static gfc_code *inserted_block, **changed_statement; 65 66/* The namespace we are currently dealing with. */ 67 68static gfc_namespace *current_ns; 69 70/* If we are within any forall loop. */ 71 72static int forall_level; 73 74/* Keep track of whether we are within an OMP workshare. */ 75 76static bool in_omp_workshare; 77 78/* Keep track of iterators for array constructors. */ 79 80static int iterator_level; 81 82/* Keep track of DO loop levels. */ 83 84static vec<gfc_code *> doloop_list; 85 86static int doloop_level; 87 88/* Vector of gfc_expr * to keep track of DO loops. */ 89 90struct my_struct *evec; 91 92/* Keep track of association lists. */ 93 94static bool in_assoc_list; 95 96/* Entry point - run all passes for a namespace. */ 97 98void 99gfc_run_passes (gfc_namespace *ns) 100{ 101 102 /* Warn about dubious DO loops where the index might 103 change. */ 104 105 doloop_level = 0; 106 doloop_warn (ns); 107 doloop_list.release (); 108 109 if (flag_frontend_optimize) 110 { 111 optimize_namespace (ns); 112 optimize_reduction (ns); 113 if (flag_dump_fortran_optimized) 114 gfc_dump_parse_tree (ns, stdout); 115 116 expr_array.release (); 117 } 118 119 if (flag_realloc_lhs) 120 realloc_strings (ns); 121} 122 123/* Callback for each gfc_code node invoked from check_realloc_strings. 124 For an allocatable LHS string which also appears as a variable on 125 the RHS, replace 126 127 a = a(x:y) 128 129 with 130 131 tmp = a(x:y) 132 a = tmp 133 */ 134 135static int 136realloc_string_callback (gfc_code **c, int *walk_subtrees, 137 void *data ATTRIBUTE_UNUSED) 138{ 139 gfc_expr *expr1, *expr2; 140 gfc_code *co = *c; 141 gfc_expr *n; 142 143 *walk_subtrees = 0; 144 if (co->op != EXEC_ASSIGN) 145 return 0; 146 147 expr1 = co->expr1; 148 if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0 149 || !expr1->symtree->n.sym->attr.allocatable) 150 return 0; 151 152 expr2 = gfc_discard_nops (co->expr2); 153 if (expr2->expr_type != EXPR_VARIABLE) 154 return 0; 155 156 if (!gfc_check_dependency (expr1, expr2, true)) 157 return 0; 158 159 current_code = c; 160 inserted_block = NULL; 161 changed_statement = NULL; 162 n = create_var (expr2); 163 co->expr2 = n; 164 return 0; 165} 166 167/* Callback for each gfc_code node invoked through gfc_code_walker 168 from optimize_namespace. */ 169 170static int 171optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 172 void *data ATTRIBUTE_UNUSED) 173{ 174 175 gfc_exec_op op; 176 177 op = (*c)->op; 178 179 if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL 180 || op == EXEC_CALL_PPC) 181 count_arglist = 1; 182 else 183 count_arglist = 0; 184 185 current_code = c; 186 inserted_block = NULL; 187 changed_statement = NULL; 188 189 if (op == EXEC_ASSIGN) 190 optimize_assignment (*c); 191 return 0; 192} 193 194/* Callback for each gfc_expr node invoked through gfc_code_walker 195 from optimize_namespace. */ 196 197static int 198optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 199 void *data ATTRIBUTE_UNUSED) 200{ 201 bool function_expr; 202 203 if ((*e)->expr_type == EXPR_FUNCTION) 204 { 205 count_arglist ++; 206 function_expr = true; 207 } 208 else 209 function_expr = false; 210 211 if (optimize_trim (*e)) 212 gfc_simplify_expr (*e, 0); 213 214 if (optimize_lexical_comparison (*e)) 215 gfc_simplify_expr (*e, 0); 216 217 if ((*e)->expr_type == EXPR_OP && optimize_op (*e)) 218 gfc_simplify_expr (*e, 0); 219 220 if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym) 221 switch ((*e)->value.function.isym->id) 222 { 223 case GFC_ISYM_MINLOC: 224 case GFC_ISYM_MAXLOC: 225 optimize_minmaxloc (e); 226 break; 227 default: 228 break; 229 } 230 231 if (function_expr) 232 count_arglist --; 233 234 return 0; 235} 236 237/* Auxiliary function to handle the arguments to reduction intrnisics. If the 238 function is a scalar, just copy it; otherwise returns the new element, the 239 old one can be freed. */ 240 241static gfc_expr * 242copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn) 243{ 244 gfc_expr *fcn, *e = c->expr; 245 246 fcn = gfc_copy_expr (e); 247 if (c->iterator) 248 { 249 gfc_constructor_base newbase; 250 gfc_expr *new_expr; 251 gfc_constructor *new_c; 252 253 newbase = NULL; 254 new_expr = gfc_get_expr (); 255 new_expr->expr_type = EXPR_ARRAY; 256 new_expr->ts = e->ts; 257 new_expr->where = e->where; 258 new_expr->rank = 1; 259 new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where)); 260 new_c->iterator = c->iterator; 261 new_expr->value.constructor = newbase; 262 c->iterator = NULL; 263 264 fcn = new_expr; 265 } 266 267 if (fcn->rank != 0) 268 { 269 gfc_isym_id id = fn->value.function.isym->id; 270 271 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) 272 fcn = gfc_build_intrinsic_call (current_ns, id, 273 fn->value.function.isym->name, 274 fn->where, 3, fcn, NULL, NULL); 275 else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL) 276 fcn = gfc_build_intrinsic_call (current_ns, id, 277 fn->value.function.isym->name, 278 fn->where, 2, fcn, NULL); 279 else 280 gfc_internal_error ("Illegal id in copy_walk_reduction_arg"); 281 282 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; 283 } 284 285 return fcn; 286} 287 288/* Callback function for optimzation of reductions to scalars. Transform ANY 289 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT 290 correspondingly. Handly only the simple cases without MASK and DIM. */ 291 292static int 293callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 294 void *data ATTRIBUTE_UNUSED) 295{ 296 gfc_expr *fn, *arg; 297 gfc_intrinsic_op op; 298 gfc_isym_id id; 299 gfc_actual_arglist *a; 300 gfc_actual_arglist *dim; 301 gfc_constructor *c; 302 gfc_expr *res, *new_expr; 303 gfc_actual_arglist *mask; 304 305 fn = *e; 306 307 if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION 308 || fn->value.function.isym == NULL) 309 return 0; 310 311 id = fn->value.function.isym->id; 312 313 if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT 314 && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL) 315 return 0; 316 317 a = fn->value.function.actual; 318 319 /* Don't handle MASK or DIM. */ 320 321 dim = a->next; 322 323 if (dim->expr != NULL) 324 return 0; 325 326 if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT) 327 { 328 mask = dim->next; 329 if ( mask->expr != NULL) 330 return 0; 331 } 332 333 arg = a->expr; 334 335 if (arg->expr_type != EXPR_ARRAY) 336 return 0; 337 338 switch (id) 339 { 340 case GFC_ISYM_SUM: 341 op = INTRINSIC_PLUS; 342 break; 343 344 case GFC_ISYM_PRODUCT: 345 op = INTRINSIC_TIMES; 346 break; 347 348 case GFC_ISYM_ANY: 349 op = INTRINSIC_OR; 350 break; 351 352 case GFC_ISYM_ALL: 353 op = INTRINSIC_AND; 354 break; 355 356 default: 357 return 0; 358 } 359 360 c = gfc_constructor_first (arg->value.constructor); 361 362 /* Don't do any simplififcation if we have 363 - no element in the constructor or 364 - only have a single element in the array which contains an 365 iterator. */ 366 367 if (c == NULL) 368 return 0; 369 370 res = copy_walk_reduction_arg (c, fn); 371 372 c = gfc_constructor_next (c); 373 while (c) 374 { 375 new_expr = gfc_get_expr (); 376 new_expr->ts = fn->ts; 377 new_expr->expr_type = EXPR_OP; 378 new_expr->rank = fn->rank; 379 new_expr->where = fn->where; 380 new_expr->value.op.op = op; 381 new_expr->value.op.op1 = res; 382 new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn); 383 res = new_expr; 384 c = gfc_constructor_next (c); 385 } 386 387 gfc_simplify_expr (res, 0); 388 *e = res; 389 gfc_free_expr (fn); 390 391 return 0; 392} 393 394/* Callback function for common function elimination, called from cfe_expr_0. 395 Put all eligible function expressions into expr_array. */ 396 397static int 398cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 399 void *data ATTRIBUTE_UNUSED) 400{ 401 402 if ((*e)->expr_type != EXPR_FUNCTION) 403 return 0; 404 405 /* We don't do character functions with unknown charlens. */ 406 if ((*e)->ts.type == BT_CHARACTER 407 && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL 408 || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT)) 409 return 0; 410 411 /* We don't do function elimination within FORALL statements, it can 412 lead to wrong-code in certain circumstances. */ 413 414 if (forall_level > 0) 415 return 0; 416 417 /* Function elimination inside an iterator could lead to functions which 418 depend on iterator variables being moved outside. FIXME: We should check 419 if the functions do indeed depend on the iterator variable. */ 420 421 if (iterator_level > 0) 422 return 0; 423 424 /* If we don't know the shape at compile time, we create an allocatable 425 temporary variable to hold the intermediate result, but only if 426 allocation on assignment is active. */ 427 428 if ((*e)->rank > 0 && (*e)->shape == NULL && !flag_realloc_lhs) 429 return 0; 430 431 /* Skip the test for pure functions if -faggressive-function-elimination 432 is specified. */ 433 if ((*e)->value.function.esym) 434 { 435 /* Don't create an array temporary for elemental functions. */ 436 if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0) 437 return 0; 438 439 /* Only eliminate potentially impure functions if the 440 user specifically requested it. */ 441 if (!flag_aggressive_function_elimination 442 && !(*e)->value.function.esym->attr.pure 443 && !(*e)->value.function.esym->attr.implicit_pure) 444 return 0; 445 } 446 447 if ((*e)->value.function.isym) 448 { 449 /* Conversions are handled on the fly by the middle end, 450 transpose during trans-* stages and TRANSFER by the middle end. */ 451 if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION 452 || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER 453 || gfc_inline_intrinsic_function_p (*e)) 454 return 0; 455 456 /* Don't create an array temporary for elemental functions, 457 as this would be wasteful of memory. 458 FIXME: Create a scalar temporary during scalarization. */ 459 if ((*e)->value.function.isym->elemental && (*e)->rank > 0) 460 return 0; 461 462 if (!(*e)->value.function.isym->pure) 463 return 0; 464 } 465 466 expr_array.safe_push (e); 467 return 0; 468} 469 470/* Auxiliary function to check if an expression is a temporary created by 471 create var. */ 472 473static bool 474is_fe_temp (gfc_expr *e) 475{ 476 if (e->expr_type != EXPR_VARIABLE) 477 return false; 478 479 return e->symtree->n.sym->attr.fe_temp; 480} 481 482/* Determine the length of a string, if it can be evaluated as a constant 483 expression. Return a newly allocated gfc_expr or NULL on failure. 484 If the user specified a substring which is potentially longer than 485 the string itself, the string will be padded with spaces, which 486 is harmless. */ 487 488static gfc_expr * 489constant_string_length (gfc_expr *e) 490{ 491 492 gfc_expr *length; 493 gfc_ref *ref; 494 gfc_expr *res; 495 mpz_t value; 496 497 if (e->ts.u.cl) 498 { 499 length = e->ts.u.cl->length; 500 if (length && length->expr_type == EXPR_CONSTANT) 501 return gfc_copy_expr(length); 502 } 503 504 /* Return length of substring, if constant. */ 505 for (ref = e->ref; ref; ref = ref->next) 506 { 507 if (ref->type == REF_SUBSTRING 508 && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value)) 509 { 510 res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, 511 &e->where); 512 513 mpz_add_ui (res->value.integer, value, 1); 514 mpz_clear (value); 515 return res; 516 } 517 } 518 519 /* Return length of char symbol, if constant. */ 520 521 if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length 522 && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 523 return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length); 524 525 return NULL; 526 527} 528 529/* Returns a new expression (a variable) to be used in place of the old one, 530 with an assignment statement before the current statement to set 531 the value of the variable. Creates a new BLOCK for the statement if 532 that hasn't already been done and puts the statement, plus the 533 newly created variables, in that block. Special cases: If the 534 expression is constant or a temporary which has already 535 been created, just copy it. */ 536 537static gfc_expr* 538create_var (gfc_expr * e) 539{ 540 char name[GFC_MAX_SYMBOL_LEN +1]; 541 static int num = 1; 542 gfc_symtree *symtree; 543 gfc_symbol *symbol; 544 gfc_expr *result; 545 gfc_code *n; 546 gfc_namespace *ns; 547 int i; 548 549 if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e)) 550 return gfc_copy_expr (e); 551 552 /* If the block hasn't already been created, do so. */ 553 if (inserted_block == NULL) 554 { 555 inserted_block = XCNEW (gfc_code); 556 inserted_block->op = EXEC_BLOCK; 557 inserted_block->loc = (*current_code)->loc; 558 ns = gfc_build_block_ns (current_ns); 559 inserted_block->ext.block.ns = ns; 560 inserted_block->ext.block.assoc = NULL; 561 562 ns->code = *current_code; 563 564 /* If the statement has a label, make sure it is transferred to 565 the newly created block. */ 566 567 if ((*current_code)->here) 568 { 569 inserted_block->here = (*current_code)->here; 570 (*current_code)->here = NULL; 571 } 572 573 inserted_block->next = (*current_code)->next; 574 changed_statement = &(inserted_block->ext.block.ns->code); 575 (*current_code)->next = NULL; 576 /* Insert the BLOCK at the right position. */ 577 *current_code = inserted_block; 578 ns->parent = current_ns; 579 } 580 else 581 ns = inserted_block->ext.block.ns; 582 583 sprintf(name, "__var_%d",num++); 584 if (gfc_get_sym_tree (name, ns, &symtree, false) != 0) 585 gcc_unreachable (); 586 587 symbol = symtree->n.sym; 588 symbol->ts = e->ts; 589 590 if (e->rank > 0) 591 { 592 symbol->as = gfc_get_array_spec (); 593 symbol->as->rank = e->rank; 594 595 if (e->shape == NULL) 596 { 597 /* We don't know the shape at compile time, so we use an 598 allocatable. */ 599 symbol->as->type = AS_DEFERRED; 600 symbol->attr.allocatable = 1; 601 } 602 else 603 { 604 symbol->as->type = AS_EXPLICIT; 605 /* Copy the shape. */ 606 for (i=0; i<e->rank; i++) 607 { 608 gfc_expr *p, *q; 609 610 p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 611 &(e->where)); 612 mpz_set_si (p->value.integer, 1); 613 symbol->as->lower[i] = p; 614 615 q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 616 &(e->where)); 617 mpz_set (q->value.integer, e->shape[i]); 618 symbol->as->upper[i] = q; 619 } 620 } 621 } 622 623 if (e->ts.type == BT_CHARACTER && e->rank == 0) 624 { 625 gfc_expr *length; 626 627 length = constant_string_length (e); 628 if (length) 629 { 630 symbol->ts.u.cl = gfc_new_charlen (ns, NULL); 631 symbol->ts.u.cl->length = length; 632 } 633 else 634 symbol->attr.allocatable = 1; 635 } 636 637 symbol->attr.flavor = FL_VARIABLE; 638 symbol->attr.referenced = 1; 639 symbol->attr.dimension = e->rank > 0; 640 symbol->attr.fe_temp = 1; 641 gfc_commit_symbol (symbol); 642 643 result = gfc_get_expr (); 644 result->expr_type = EXPR_VARIABLE; 645 result->ts = e->ts; 646 result->rank = e->rank; 647 result->shape = gfc_copy_shape (e->shape, e->rank); 648 result->symtree = symtree; 649 result->where = e->where; 650 if (e->rank > 0) 651 { 652 result->ref = gfc_get_ref (); 653 result->ref->type = REF_ARRAY; 654 result->ref->u.ar.type = AR_FULL; 655 result->ref->u.ar.where = e->where; 656 result->ref->u.ar.as = symbol->ts.type == BT_CLASS 657 ? CLASS_DATA (symbol)->as : symbol->as; 658 if (warn_array_temporaries) 659 gfc_warning (OPT_Warray_temporaries, 660 "Creating array temporary at %L", &(e->where)); 661 } 662 663 /* Generate the new assignment. */ 664 n = XCNEW (gfc_code); 665 n->op = EXEC_ASSIGN; 666 n->loc = (*current_code)->loc; 667 n->next = *changed_statement; 668 n->expr1 = gfc_copy_expr (result); 669 n->expr2 = e; 670 *changed_statement = n; 671 672 return result; 673} 674 675/* Warn about function elimination. */ 676 677static void 678do_warn_function_elimination (gfc_expr *e) 679{ 680 if (e->expr_type != EXPR_FUNCTION) 681 return; 682 if (e->value.function.esym) 683 gfc_warning (0, "Removing call to function %qs at %L", 684 e->value.function.esym->name, &(e->where)); 685 else if (e->value.function.isym) 686 gfc_warning (0, "Removing call to function %qs at %L", 687 e->value.function.isym->name, &(e->where)); 688} 689/* Callback function for the code walker for doing common function 690 elimination. This builds up the list of functions in the expression 691 and goes through them to detect duplicates, which it then replaces 692 by variables. */ 693 694static int 695cfe_expr_0 (gfc_expr **e, int *walk_subtrees, 696 void *data ATTRIBUTE_UNUSED) 697{ 698 int i,j; 699 gfc_expr *newvar; 700 gfc_expr **ei, **ej; 701 702 /* Don't do this optimization within OMP workshare. */ 703 704 if (in_omp_workshare) 705 { 706 *walk_subtrees = 0; 707 return 0; 708 } 709 710 expr_array.release (); 711 712 gfc_expr_walker (e, cfe_register_funcs, NULL); 713 714 /* Walk through all the functions. */ 715 716 FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1) 717 { 718 /* Skip if the function has been replaced by a variable already. */ 719 if ((*ei)->expr_type == EXPR_VARIABLE) 720 continue; 721 722 newvar = NULL; 723 for (j=0; j<i; j++) 724 { 725 ej = expr_array[j]; 726 if (gfc_dep_compare_functions (*ei, *ej, true) == 0) 727 { 728 if (newvar == NULL) 729 newvar = create_var (*ei); 730 731 if (warn_function_elimination) 732 do_warn_function_elimination (*ej); 733 734 free (*ej); 735 *ej = gfc_copy_expr (newvar); 736 } 737 } 738 if (newvar) 739 *ei = newvar; 740 } 741 742 /* We did all the necessary walking in this function. */ 743 *walk_subtrees = 0; 744 return 0; 745} 746 747/* Callback function for common function elimination, called from 748 gfc_code_walker. This keeps track of the current code, in order 749 to insert statements as needed. */ 750 751static int 752cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) 753{ 754 current_code = c; 755 inserted_block = NULL; 756 changed_statement = NULL; 757 758 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs 759 and allocation on assigment are prohibited inside WHERE, and finally 760 masking an expression would lead to wrong-code when replacing 761 762 WHERE (a>0) 763 b = sum(foo(a) + foo(a)) 764 END WHERE 765 766 with 767 768 WHERE (a > 0) 769 tmp = foo(a) 770 b = sum(tmp + tmp) 771 END WHERE 772*/ 773 774 if ((*c)->op == EXEC_WHERE) 775 { 776 *walk_subtrees = 0; 777 return 0; 778 } 779 780 781 return 0; 782} 783 784/* Dummy function for expression call back, for use when we 785 really don't want to do any walking. */ 786 787static int 788dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees, 789 void *data ATTRIBUTE_UNUSED) 790{ 791 *walk_subtrees = 0; 792 return 0; 793} 794 795/* Dummy function for code callback, for use when we really 796 don't want to do anything. */ 797int 798gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED, 799 int *walk_subtrees ATTRIBUTE_UNUSED, 800 void *data ATTRIBUTE_UNUSED) 801{ 802 return 0; 803} 804 805/* Code callback function for converting 806 do while(a) 807 end do 808 into the equivalent 809 do 810 if (.not. a) exit 811 end do 812 This is because common function elimination would otherwise place the 813 temporary variables outside the loop. */ 814 815static int 816convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 817 void *data ATTRIBUTE_UNUSED) 818{ 819 gfc_code *co = *c; 820 gfc_code *c_if1, *c_if2, *c_exit; 821 gfc_code *loopblock; 822 gfc_expr *e_not, *e_cond; 823 824 if (co->op != EXEC_DO_WHILE) 825 return 0; 826 827 if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT) 828 return 0; 829 830 e_cond = co->expr1; 831 832 /* Generate the condition of the if statement, which is .not. the original 833 statement. */ 834 e_not = gfc_get_expr (); 835 e_not->ts = e_cond->ts; 836 e_not->where = e_cond->where; 837 e_not->expr_type = EXPR_OP; 838 e_not->value.op.op = INTRINSIC_NOT; 839 e_not->value.op.op1 = e_cond; 840 841 /* Generate the EXIT statement. */ 842 c_exit = XCNEW (gfc_code); 843 c_exit->op = EXEC_EXIT; 844 c_exit->ext.which_construct = co; 845 c_exit->loc = co->loc; 846 847 /* Generate the IF statement. */ 848 c_if2 = XCNEW (gfc_code); 849 c_if2->op = EXEC_IF; 850 c_if2->expr1 = e_not; 851 c_if2->next = c_exit; 852 c_if2->loc = co->loc; 853 854 /* ... plus the one to chain it to. */ 855 c_if1 = XCNEW (gfc_code); 856 c_if1->op = EXEC_IF; 857 c_if1->block = c_if2; 858 c_if1->loc = co->loc; 859 860 /* Make the DO WHILE loop into a DO block by replacing the condition 861 with a true constant. */ 862 co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true); 863 864 /* Hang the generated if statement into the loop body. */ 865 866 loopblock = co->block->next; 867 co->block->next = c_if1; 868 c_if1->next = loopblock; 869 870 return 0; 871} 872 873/* Code callback function for converting 874 if (a) then 875 ... 876 else if (b) then 877 end if 878 879 into 880 if (a) then 881 else 882 if (b) then 883 end if 884 end if 885 886 because otherwise common function elimination would place the BLOCKs 887 into the wrong place. */ 888 889static int 890convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 891 void *data ATTRIBUTE_UNUSED) 892{ 893 gfc_code *co = *c; 894 gfc_code *c_if1, *c_if2, *else_stmt; 895 896 if (co->op != EXEC_IF) 897 return 0; 898 899 /* This loop starts out with the first ELSE statement. */ 900 else_stmt = co->block->block; 901 902 while (else_stmt != NULL) 903 { 904 gfc_code *next_else; 905 906 /* If there is no condition, we're done. */ 907 if (else_stmt->expr1 == NULL) 908 break; 909 910 next_else = else_stmt->block; 911 912 /* Generate the new IF statement. */ 913 c_if2 = XCNEW (gfc_code); 914 c_if2->op = EXEC_IF; 915 c_if2->expr1 = else_stmt->expr1; 916 c_if2->next = else_stmt->next; 917 c_if2->loc = else_stmt->loc; 918 c_if2->block = next_else; 919 920 /* ... plus the one to chain it to. */ 921 c_if1 = XCNEW (gfc_code); 922 c_if1->op = EXEC_IF; 923 c_if1->block = c_if2; 924 c_if1->loc = else_stmt->loc; 925 926 /* Insert the new IF after the ELSE. */ 927 else_stmt->expr1 = NULL; 928 else_stmt->next = c_if1; 929 else_stmt->block = NULL; 930 931 else_stmt = next_else; 932 } 933 /* Don't walk subtrees. */ 934 return 0; 935} 936/* Optimize a namespace, including all contained namespaces. */ 937 938static void 939optimize_namespace (gfc_namespace *ns) 940{ 941 942 current_ns = ns; 943 forall_level = 0; 944 iterator_level = 0; 945 in_assoc_list = false; 946 in_omp_workshare = false; 947 948 gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); 949 gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); 950 gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); 951 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); 952 953 /* BLOCKs are handled in the expression walker below. */ 954 for (ns = ns->contained; ns; ns = ns->sibling) 955 { 956 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 957 optimize_namespace (ns); 958 } 959} 960 961/* Handle dependencies for allocatable strings which potentially redefine 962 themselves in an assignment. */ 963 964static void 965realloc_strings (gfc_namespace *ns) 966{ 967 current_ns = ns; 968 gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL); 969 970 for (ns = ns->contained; ns; ns = ns->sibling) 971 { 972 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 973 { 974 // current_ns = ns; 975 realloc_strings (ns); 976 } 977 } 978 979} 980 981static void 982optimize_reduction (gfc_namespace *ns) 983{ 984 current_ns = ns; 985 gfc_code_walker (&ns->code, gfc_dummy_code_callback, 986 callback_reduction, NULL); 987 988/* BLOCKs are handled in the expression walker below. */ 989 for (ns = ns->contained; ns; ns = ns->sibling) 990 { 991 if (ns->code == NULL || ns->code->op != EXEC_BLOCK) 992 optimize_reduction (ns); 993 } 994} 995 996/* Replace code like 997 a = matmul(b,c) + d 998 with 999 a = matmul(b,c) ; a = a + d 1000 where the array function is not elemental and not allocatable 1001 and does not depend on the left-hand side. 1002*/ 1003 1004static bool 1005optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op) 1006{ 1007 gfc_expr *e; 1008 1009 e = *rhs; 1010 if (e->expr_type == EXPR_OP) 1011 { 1012 switch (e->value.op.op) 1013 { 1014 /* Unary operators and exponentiation: Only look at a single 1015 operand. */ 1016 case INTRINSIC_NOT: 1017 case INTRINSIC_UPLUS: 1018 case INTRINSIC_UMINUS: 1019 case INTRINSIC_PARENTHESES: 1020 case INTRINSIC_POWER: 1021 if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op)) 1022 return true; 1023 break; 1024 1025 case INTRINSIC_CONCAT: 1026 /* Do not do string concatenations. */ 1027 break; 1028 1029 default: 1030 /* Binary operators. */ 1031 if (optimize_binop_array_assignment (c, &e->value.op.op1, true)) 1032 return true; 1033 1034 if (optimize_binop_array_assignment (c, &e->value.op.op2, true)) 1035 return true; 1036 1037 break; 1038 } 1039 } 1040 else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0 1041 && ! (e->value.function.esym 1042 && (e->value.function.esym->attr.elemental 1043 || e->value.function.esym->attr.allocatable 1044 || e->value.function.esym->ts.type != c->expr1->ts.type 1045 || e->value.function.esym->ts.kind != c->expr1->ts.kind)) 1046 && ! (e->value.function.isym 1047 && (e->value.function.isym->elemental 1048 || e->ts.type != c->expr1->ts.type 1049 || e->ts.kind != c->expr1->ts.kind)) 1050 && ! gfc_inline_intrinsic_function_p (e)) 1051 { 1052 1053 gfc_code *n; 1054 gfc_expr *new_expr; 1055 1056 /* Insert a new assignment statement after the current one. */ 1057 n = XCNEW (gfc_code); 1058 n->op = EXEC_ASSIGN; 1059 n->loc = c->loc; 1060 n->next = c->next; 1061 c->next = n; 1062 1063 n->expr1 = gfc_copy_expr (c->expr1); 1064 n->expr2 = c->expr2; 1065 new_expr = gfc_copy_expr (c->expr1); 1066 c->expr2 = e; 1067 *rhs = new_expr; 1068 1069 return true; 1070 1071 } 1072 1073 /* Nothing to optimize. */ 1074 return false; 1075} 1076 1077/* Remove unneeded TRIMs at the end of expressions. */ 1078 1079static bool 1080remove_trim (gfc_expr *rhs) 1081{ 1082 bool ret; 1083 1084 ret = false; 1085 1086 /* Check for a // b // trim(c). Looping is probably not 1087 necessary because the parser usually generates 1088 (// (// a b ) trim(c) ) , but better safe than sorry. */ 1089 1090 while (rhs->expr_type == EXPR_OP 1091 && rhs->value.op.op == INTRINSIC_CONCAT) 1092 rhs = rhs->value.op.op2; 1093 1094 while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym 1095 && rhs->value.function.isym->id == GFC_ISYM_TRIM) 1096 { 1097 strip_function_call (rhs); 1098 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */ 1099 remove_trim (rhs); 1100 ret = true; 1101 } 1102 1103 return ret; 1104} 1105 1106/* Optimizations for an assignment. */ 1107 1108static void 1109optimize_assignment (gfc_code * c) 1110{ 1111 gfc_expr *lhs, *rhs; 1112 1113 lhs = c->expr1; 1114 rhs = c->expr2; 1115 1116 if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred) 1117 { 1118 /* Optimize a = trim(b) to a = b. */ 1119 remove_trim (rhs); 1120 1121 /* Replace a = ' ' by a = '' to optimize away a memcpy. */ 1122 if (is_empty_string (rhs)) 1123 rhs->value.character.length = 0; 1124 } 1125 1126 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0) 1127 optimize_binop_array_assignment (c, &rhs, false); 1128} 1129 1130 1131/* Remove an unneeded function call, modifying the expression. 1132 This replaces the function call with the value of its 1133 first argument. The rest of the argument list is freed. */ 1134 1135static void 1136strip_function_call (gfc_expr *e) 1137{ 1138 gfc_expr *e1; 1139 gfc_actual_arglist *a; 1140 1141 a = e->value.function.actual; 1142 1143 /* We should have at least one argument. */ 1144 gcc_assert (a->expr != NULL); 1145 1146 e1 = a->expr; 1147 1148 /* Free the remaining arglist, if any. */ 1149 if (a->next) 1150 gfc_free_actual_arglist (a->next); 1151 1152 /* Graft the argument expression onto the original function. */ 1153 *e = *e1; 1154 free (e1); 1155 1156} 1157 1158/* Optimization of lexical comparison functions. */ 1159 1160static bool 1161optimize_lexical_comparison (gfc_expr *e) 1162{ 1163 if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL) 1164 return false; 1165 1166 switch (e->value.function.isym->id) 1167 { 1168 case GFC_ISYM_LLE: 1169 return optimize_comparison (e, INTRINSIC_LE); 1170 1171 case GFC_ISYM_LGE: 1172 return optimize_comparison (e, INTRINSIC_GE); 1173 1174 case GFC_ISYM_LGT: 1175 return optimize_comparison (e, INTRINSIC_GT); 1176 1177 case GFC_ISYM_LLT: 1178 return optimize_comparison (e, INTRINSIC_LT); 1179 1180 default: 1181 break; 1182 } 1183 return false; 1184} 1185 1186/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not 1187 do CHARACTER because of possible pessimization involving character 1188 lengths. */ 1189 1190static bool 1191combine_array_constructor (gfc_expr *e) 1192{ 1193 1194 gfc_expr *op1, *op2; 1195 gfc_expr *scalar; 1196 gfc_expr *new_expr; 1197 gfc_constructor *c, *new_c; 1198 gfc_constructor_base oldbase, newbase; 1199 bool scalar_first; 1200 1201 /* Array constructors have rank one. */ 1202 if (e->rank != 1) 1203 return false; 1204 1205 /* Don't try to combine association lists, this makes no sense 1206 and leads to an ICE. */ 1207 if (in_assoc_list) 1208 return false; 1209 1210 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */ 1211 if (forall_level > 0) 1212 return false; 1213 1214 op1 = e->value.op.op1; 1215 op2 = e->value.op.op2; 1216 1217 if (op1->expr_type == EXPR_ARRAY && op2->rank == 0) 1218 scalar_first = false; 1219 else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0) 1220 { 1221 scalar_first = true; 1222 op1 = e->value.op.op2; 1223 op2 = e->value.op.op1; 1224 } 1225 else 1226 return false; 1227 1228 if (op2->ts.type == BT_CHARACTER) 1229 return false; 1230 1231 scalar = create_var (gfc_copy_expr (op2)); 1232 1233 oldbase = op1->value.constructor; 1234 newbase = NULL; 1235 e->expr_type = EXPR_ARRAY; 1236 1237 for (c = gfc_constructor_first (oldbase); c; 1238 c = gfc_constructor_next (c)) 1239 { 1240 new_expr = gfc_get_expr (); 1241 new_expr->ts = e->ts; 1242 new_expr->expr_type = EXPR_OP; 1243 new_expr->rank = c->expr->rank; 1244 new_expr->where = c->where; 1245 new_expr->value.op.op = e->value.op.op; 1246 1247 if (scalar_first) 1248 { 1249 new_expr->value.op.op1 = gfc_copy_expr (scalar); 1250 new_expr->value.op.op2 = gfc_copy_expr (c->expr); 1251 } 1252 else 1253 { 1254 new_expr->value.op.op1 = gfc_copy_expr (c->expr); 1255 new_expr->value.op.op2 = gfc_copy_expr (scalar); 1256 } 1257 1258 new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where)); 1259 new_c->iterator = c->iterator; 1260 c->iterator = NULL; 1261 } 1262 1263 gfc_free_expr (op1); 1264 gfc_free_expr (op2); 1265 gfc_free_expr (scalar); 1266 1267 e->value.constructor = newbase; 1268 return true; 1269} 1270 1271/* Change (-1)**k into 1-ishift(iand(k,1),1) and 1272 2**k into ishift(1,k) */ 1273 1274static bool 1275optimize_power (gfc_expr *e) 1276{ 1277 gfc_expr *op1, *op2; 1278 gfc_expr *iand, *ishft; 1279 1280 if (e->ts.type != BT_INTEGER) 1281 return false; 1282 1283 op1 = e->value.op.op1; 1284 1285 if (op1 == NULL || op1->expr_type != EXPR_CONSTANT) 1286 return false; 1287 1288 if (mpz_cmp_si (op1->value.integer, -1L) == 0) 1289 { 1290 gfc_free_expr (op1); 1291 1292 op2 = e->value.op.op2; 1293 1294 if (op2 == NULL) 1295 return false; 1296 1297 iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND, 1298 "_internal_iand", e->where, 2, op2, 1299 gfc_get_int_expr (e->ts.kind, 1300 &e->where, 1)); 1301 1302 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT, 1303 "_internal_ishft", e->where, 2, iand, 1304 gfc_get_int_expr (e->ts.kind, 1305 &e->where, 1)); 1306 1307 e->value.op.op = INTRINSIC_MINUS; 1308 e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1); 1309 e->value.op.op2 = ishft; 1310 return true; 1311 } 1312 else if (mpz_cmp_si (op1->value.integer, 2L) == 0) 1313 { 1314 gfc_free_expr (op1); 1315 1316 op2 = e->value.op.op2; 1317 if (op2 == NULL) 1318 return false; 1319 1320 ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT, 1321 "_internal_ishft", e->where, 2, 1322 gfc_get_int_expr (e->ts.kind, 1323 &e->where, 1), 1324 op2); 1325 *e = *ishft; 1326 return true; 1327 } 1328 1329 else if (mpz_cmp_si (op1->value.integer, 1L) == 0) 1330 { 1331 op2 = e->value.op.op2; 1332 if (op2 == NULL) 1333 return false; 1334 1335 gfc_free_expr (op1); 1336 gfc_free_expr (op2); 1337 1338 e->expr_type = EXPR_CONSTANT; 1339 e->value.op.op1 = NULL; 1340 e->value.op.op2 = NULL; 1341 mpz_init_set_si (e->value.integer, 1); 1342 /* Typespec and location are still OK. */ 1343 return true; 1344 } 1345 1346 return false; 1347} 1348 1349/* Recursive optimization of operators. */ 1350 1351static bool 1352optimize_op (gfc_expr *e) 1353{ 1354 bool changed; 1355 1356 gfc_intrinsic_op op = e->value.op.op; 1357 1358 changed = false; 1359 1360 /* Only use new-style comparisons. */ 1361 switch(op) 1362 { 1363 case INTRINSIC_EQ_OS: 1364 op = INTRINSIC_EQ; 1365 break; 1366 1367 case INTRINSIC_GE_OS: 1368 op = INTRINSIC_GE; 1369 break; 1370 1371 case INTRINSIC_LE_OS: 1372 op = INTRINSIC_LE; 1373 break; 1374 1375 case INTRINSIC_NE_OS: 1376 op = INTRINSIC_NE; 1377 break; 1378 1379 case INTRINSIC_GT_OS: 1380 op = INTRINSIC_GT; 1381 break; 1382 1383 case INTRINSIC_LT_OS: 1384 op = INTRINSIC_LT; 1385 break; 1386 1387 default: 1388 break; 1389 } 1390 1391 switch (op) 1392 { 1393 case INTRINSIC_EQ: 1394 case INTRINSIC_GE: 1395 case INTRINSIC_LE: 1396 case INTRINSIC_NE: 1397 case INTRINSIC_GT: 1398 case INTRINSIC_LT: 1399 changed = optimize_comparison (e, op); 1400 1401 /* Fall through */ 1402 /* Look at array constructors. */ 1403 case INTRINSIC_PLUS: 1404 case INTRINSIC_MINUS: 1405 case INTRINSIC_TIMES: 1406 case INTRINSIC_DIVIDE: 1407 return combine_array_constructor (e) || changed; 1408 1409 case INTRINSIC_POWER: 1410 return optimize_power (e); 1411 break; 1412 1413 default: 1414 break; 1415 } 1416 1417 return false; 1418} 1419 1420 1421/* Return true if a constant string contains only blanks. */ 1422 1423static bool 1424is_empty_string (gfc_expr *e) 1425{ 1426 int i; 1427 1428 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) 1429 return false; 1430 1431 for (i=0; i < e->value.character.length; i++) 1432 { 1433 if (e->value.character.string[i] != ' ') 1434 return false; 1435 } 1436 1437 return true; 1438} 1439 1440 1441/* Insert a call to the intrinsic len_trim. Use a different name for 1442 the symbol tree so we don't run into trouble when the user has 1443 renamed len_trim for some reason. */ 1444 1445static gfc_expr* 1446get_len_trim_call (gfc_expr *str, int kind) 1447{ 1448 gfc_expr *fcn; 1449 gfc_actual_arglist *actual_arglist, *next; 1450 1451 fcn = gfc_get_expr (); 1452 fcn->expr_type = EXPR_FUNCTION; 1453 fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM); 1454 actual_arglist = gfc_get_actual_arglist (); 1455 actual_arglist->expr = str; 1456 next = gfc_get_actual_arglist (); 1457 next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind); 1458 actual_arglist->next = next; 1459 1460 fcn->value.function.actual = actual_arglist; 1461 fcn->where = str->where; 1462 fcn->ts.type = BT_INTEGER; 1463 fcn->ts.kind = gfc_charlen_int_kind; 1464 1465 gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false); 1466 fcn->symtree->n.sym->ts = fcn->ts; 1467 fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE; 1468 fcn->symtree->n.sym->attr.function = 1; 1469 fcn->symtree->n.sym->attr.elemental = 1; 1470 fcn->symtree->n.sym->attr.referenced = 1; 1471 fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE; 1472 gfc_commit_symbol (fcn->symtree->n.sym); 1473 1474 return fcn; 1475} 1476 1477/* Optimize expressions for equality. */ 1478 1479static bool 1480optimize_comparison (gfc_expr *e, gfc_intrinsic_op op) 1481{ 1482 gfc_expr *op1, *op2; 1483 bool change; 1484 int eq; 1485 bool result; 1486 gfc_actual_arglist *firstarg, *secondarg; 1487 1488 if (e->expr_type == EXPR_OP) 1489 { 1490 firstarg = NULL; 1491 secondarg = NULL; 1492 op1 = e->value.op.op1; 1493 op2 = e->value.op.op2; 1494 } 1495 else if (e->expr_type == EXPR_FUNCTION) 1496 { 1497 /* One of the lexical comparison functions. */ 1498 firstarg = e->value.function.actual; 1499 secondarg = firstarg->next; 1500 op1 = firstarg->expr; 1501 op2 = secondarg->expr; 1502 } 1503 else 1504 gcc_unreachable (); 1505 1506 /* Strip off unneeded TRIM calls from string comparisons. */ 1507 1508 change = remove_trim (op1); 1509 1510 if (remove_trim (op2)) 1511 change = true; 1512 1513 /* An expression of type EXPR_CONSTANT is only valid for scalars. */ 1514 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer 1515 handles them well). However, there are also cases that need a non-scalar 1516 argument. For example the any intrinsic. See PR 45380. */ 1517 if (e->rank > 0) 1518 return change; 1519 1520 /* Replace a == '' with len_trim(a) == 0 and a /= '' with 1521 len_trim(a) != 0 */ 1522 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 1523 && (op == INTRINSIC_EQ || op == INTRINSIC_NE)) 1524 { 1525 bool empty_op1, empty_op2; 1526 empty_op1 = is_empty_string (op1); 1527 empty_op2 = is_empty_string (op2); 1528 1529 if (empty_op1 || empty_op2) 1530 { 1531 gfc_expr *fcn; 1532 gfc_expr *zero; 1533 gfc_expr *str; 1534 1535 /* This can only happen when an error for comparing 1536 characters of different kinds has already been issued. */ 1537 if (empty_op1 && empty_op2) 1538 return false; 1539 1540 zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0); 1541 str = empty_op1 ? op2 : op1; 1542 1543 fcn = get_len_trim_call (str, gfc_charlen_int_kind); 1544 1545 1546 if (empty_op1) 1547 gfc_free_expr (op1); 1548 else 1549 gfc_free_expr (op2); 1550 1551 op1 = fcn; 1552 op2 = zero; 1553 e->value.op.op1 = fcn; 1554 e->value.op.op2 = zero; 1555 } 1556 } 1557 1558 1559 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */ 1560 1561 if (flag_finite_math_only 1562 || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL 1563 && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX)) 1564 { 1565 eq = gfc_dep_compare_expr (op1, op2); 1566 if (eq <= -2) 1567 { 1568 /* Replace A // B < A // C with B < C, and A // B < C // B 1569 with A < C. */ 1570 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 1571 && op1->expr_type == EXPR_OP 1572 && op1->value.op.op == INTRINSIC_CONCAT 1573 && op2->expr_type == EXPR_OP 1574 && op2->value.op.op == INTRINSIC_CONCAT) 1575 { 1576 gfc_expr *op1_left = op1->value.op.op1; 1577 gfc_expr *op2_left = op2->value.op.op1; 1578 gfc_expr *op1_right = op1->value.op.op2; 1579 gfc_expr *op2_right = op2->value.op.op2; 1580 1581 if (gfc_dep_compare_expr (op1_left, op2_left) == 0) 1582 { 1583 /* Watch out for 'A ' // x vs. 'A' // x. */ 1584 1585 if (op1_left->expr_type == EXPR_CONSTANT 1586 && op2_left->expr_type == EXPR_CONSTANT 1587 && op1_left->value.character.length 1588 != op2_left->value.character.length) 1589 return change; 1590 else 1591 { 1592 free (op1_left); 1593 free (op2_left); 1594 if (firstarg) 1595 { 1596 firstarg->expr = op1_right; 1597 secondarg->expr = op2_right; 1598 } 1599 else 1600 { 1601 e->value.op.op1 = op1_right; 1602 e->value.op.op2 = op2_right; 1603 } 1604 optimize_comparison (e, op); 1605 return true; 1606 } 1607 } 1608 if (gfc_dep_compare_expr (op1_right, op2_right) == 0) 1609 { 1610 free (op1_right); 1611 free (op2_right); 1612 if (firstarg) 1613 { 1614 firstarg->expr = op1_left; 1615 secondarg->expr = op2_left; 1616 } 1617 else 1618 { 1619 e->value.op.op1 = op1_left; 1620 e->value.op.op2 = op2_left; 1621 } 1622 1623 optimize_comparison (e, op); 1624 return true; 1625 } 1626 } 1627 } 1628 else 1629 { 1630 /* eq can only be -1, 0 or 1 at this point. */ 1631 switch (op) 1632 { 1633 case INTRINSIC_EQ: 1634 result = eq == 0; 1635 break; 1636 1637 case INTRINSIC_GE: 1638 result = eq >= 0; 1639 break; 1640 1641 case INTRINSIC_LE: 1642 result = eq <= 0; 1643 break; 1644 1645 case INTRINSIC_NE: 1646 result = eq != 0; 1647 break; 1648 1649 case INTRINSIC_GT: 1650 result = eq > 0; 1651 break; 1652 1653 case INTRINSIC_LT: 1654 result = eq < 0; 1655 break; 1656 1657 default: 1658 gfc_internal_error ("illegal OP in optimize_comparison"); 1659 break; 1660 } 1661 1662 /* Replace the expression by a constant expression. The typespec 1663 and where remains the way it is. */ 1664 free (op1); 1665 free (op2); 1666 e->expr_type = EXPR_CONSTANT; 1667 e->value.logical = result; 1668 return true; 1669 } 1670 } 1671 1672 return change; 1673} 1674 1675/* Optimize a trim function by replacing it with an equivalent substring 1676 involving a call to len_trim. This only works for expressions where 1677 variables are trimmed. Return true if anything was modified. */ 1678 1679static bool 1680optimize_trim (gfc_expr *e) 1681{ 1682 gfc_expr *a; 1683 gfc_ref *ref; 1684 gfc_expr *fcn; 1685 gfc_ref **rr = NULL; 1686 1687 /* Don't do this optimization within an argument list, because 1688 otherwise aliasing issues may occur. */ 1689 1690 if (count_arglist != 1) 1691 return false; 1692 1693 if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION 1694 || e->value.function.isym == NULL 1695 || e->value.function.isym->id != GFC_ISYM_TRIM) 1696 return false; 1697 1698 a = e->value.function.actual->expr; 1699 1700 if (a->expr_type != EXPR_VARIABLE) 1701 return false; 1702 1703 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */ 1704 1705 if (a->symtree->n.sym->attr.allocatable) 1706 return false; 1707 1708 /* Follow all references to find the correct place to put the newly 1709 created reference. FIXME: Also handle substring references and 1710 array references. Array references cause strange regressions at 1711 the moment. */ 1712 1713 if (a->ref) 1714 { 1715 for (rr = &(a->ref); *rr; rr = &((*rr)->next)) 1716 { 1717 if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY) 1718 return false; 1719 } 1720 } 1721 1722 strip_function_call (e); 1723 1724 if (e->ref == NULL) 1725 rr = &(e->ref); 1726 1727 /* Create the reference. */ 1728 1729 ref = gfc_get_ref (); 1730 ref->type = REF_SUBSTRING; 1731 1732 /* Set the start of the reference. */ 1733 1734 ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 1735 1736 /* Build the function call to len_trim(x, gfc_default_integer_kind). */ 1737 1738 fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind); 1739 1740 /* Set the end of the reference to the call to len_trim. */ 1741 1742 ref->u.ss.end = fcn; 1743 gcc_assert (rr != NULL && *rr == NULL); 1744 *rr = ref; 1745 return true; 1746} 1747 1748/* Optimize minloc(b), where b is rank 1 array, into 1749 (/ minloc(b, dim=1) /), and similarly for maxloc, 1750 as the latter forms are expanded inline. */ 1751 1752static void 1753optimize_minmaxloc (gfc_expr **e) 1754{ 1755 gfc_expr *fn = *e; 1756 gfc_actual_arglist *a; 1757 char *name, *p; 1758 1759 if (fn->rank != 1 1760 || fn->value.function.actual == NULL 1761 || fn->value.function.actual->expr == NULL 1762 || fn->value.function.actual->expr->rank != 1) 1763 return; 1764 1765 *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where); 1766 (*e)->shape = fn->shape; 1767 fn->rank = 0; 1768 fn->shape = NULL; 1769 gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where); 1770 1771 name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1); 1772 strcpy (name, fn->value.function.name); 1773 p = strstr (name, "loc0"); 1774 p[3] = '1'; 1775 fn->value.function.name = gfc_get_string (name); 1776 if (fn->value.function.actual->next) 1777 { 1778 a = fn->value.function.actual->next; 1779 gcc_assert (a->expr == NULL); 1780 } 1781 else 1782 { 1783 a = gfc_get_actual_arglist (); 1784 fn->value.function.actual->next = a; 1785 } 1786 a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 1787 &fn->where); 1788 mpz_set_ui (a->expr->value.integer, 1); 1789} 1790 1791/* Callback function for code checking that we do not pass a DO variable to an 1792 INTENT(OUT) or INTENT(INOUT) dummy variable. */ 1793 1794static int 1795doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, 1796 void *data ATTRIBUTE_UNUSED) 1797{ 1798 gfc_code *co; 1799 int i; 1800 gfc_formal_arglist *f; 1801 gfc_actual_arglist *a; 1802 gfc_code *cl; 1803 1804 co = *c; 1805 1806 /* If the doloop_list grew, we have to truncate it here. */ 1807 1808 if ((unsigned) doloop_level < doloop_list.length()) 1809 doloop_list.truncate (doloop_level); 1810 1811 switch (co->op) 1812 { 1813 case EXEC_DO: 1814 1815 if (co->ext.iterator && co->ext.iterator->var) 1816 doloop_list.safe_push (co); 1817 else 1818 doloop_list.safe_push ((gfc_code *) NULL); 1819 break; 1820 1821 case EXEC_CALL: 1822 1823 if (co->resolved_sym == NULL) 1824 break; 1825 1826 f = gfc_sym_get_dummy_args (co->resolved_sym); 1827 1828 /* Withot a formal arglist, there is only unknown INTENT, 1829 which we don't check for. */ 1830 if (f == NULL) 1831 break; 1832 1833 a = co->ext.actual; 1834 1835 while (a && f) 1836 { 1837 FOR_EACH_VEC_ELT (doloop_list, i, cl) 1838 { 1839 gfc_symbol *do_sym; 1840 1841 if (cl == NULL) 1842 break; 1843 1844 do_sym = cl->ext.iterator->var->symtree->n.sym; 1845 1846 if (a->expr && a->expr->symtree 1847 && a->expr->symtree->n.sym == do_sym) 1848 { 1849 if (f->sym->attr.intent == INTENT_OUT) 1850 gfc_error_now_1 ("Variable '%s' at %L set to undefined " 1851 "value inside loop beginning at %L as " 1852 "INTENT(OUT) argument to subroutine '%s'", 1853 do_sym->name, &a->expr->where, 1854 &doloop_list[i]->loc, 1855 co->symtree->n.sym->name); 1856 else if (f->sym->attr.intent == INTENT_INOUT) 1857 gfc_error_now_1 ("Variable '%s' at %L not definable inside " 1858 "loop beginning at %L as INTENT(INOUT) " 1859 "argument to subroutine '%s'", 1860 do_sym->name, &a->expr->where, 1861 &doloop_list[i]->loc, 1862 co->symtree->n.sym->name); 1863 } 1864 } 1865 a = a->next; 1866 f = f->next; 1867 } 1868 break; 1869 1870 default: 1871 break; 1872 } 1873 return 0; 1874} 1875 1876/* Callback function for functions checking that we do not pass a DO variable 1877 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */ 1878 1879static int 1880do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 1881 void *data ATTRIBUTE_UNUSED) 1882{ 1883 gfc_formal_arglist *f; 1884 gfc_actual_arglist *a; 1885 gfc_expr *expr; 1886 gfc_code *dl; 1887 int i; 1888 1889 expr = *e; 1890 if (expr->expr_type != EXPR_FUNCTION) 1891 return 0; 1892 1893 /* Intrinsic functions don't modify their arguments. */ 1894 1895 if (expr->value.function.isym) 1896 return 0; 1897 1898 f = gfc_sym_get_dummy_args (expr->symtree->n.sym); 1899 1900 /* Without a formal arglist, there is only unknown INTENT, 1901 which we don't check for. */ 1902 if (f == NULL) 1903 return 0; 1904 1905 a = expr->value.function.actual; 1906 1907 while (a && f) 1908 { 1909 FOR_EACH_VEC_ELT (doloop_list, i, dl) 1910 { 1911 gfc_symbol *do_sym; 1912 1913 if (dl == NULL) 1914 break; 1915 1916 do_sym = dl->ext.iterator->var->symtree->n.sym; 1917 1918 if (a->expr && a->expr->symtree 1919 && a->expr->symtree->n.sym == do_sym) 1920 { 1921 if (f->sym->attr.intent == INTENT_OUT) 1922 gfc_error_now_1 ("Variable '%s' at %L set to undefined value " 1923 "inside loop beginning at %L as INTENT(OUT) " 1924 "argument to function '%s'", do_sym->name, 1925 &a->expr->where, &doloop_list[i]->loc, 1926 expr->symtree->n.sym->name); 1927 else if (f->sym->attr.intent == INTENT_INOUT) 1928 gfc_error_now_1 ("Variable '%s' at %L not definable inside loop" 1929 " beginning at %L as INTENT(INOUT) argument to" 1930 " function '%s'", do_sym->name, 1931 &a->expr->where, &doloop_list[i]->loc, 1932 expr->symtree->n.sym->name); 1933 } 1934 } 1935 a = a->next; 1936 f = f->next; 1937 } 1938 1939 return 0; 1940} 1941 1942static void 1943doloop_warn (gfc_namespace *ns) 1944{ 1945 gfc_code_walker (&ns->code, doloop_code, do_function, NULL); 1946} 1947 1948 1949#define WALK_SUBEXPR(NODE) \ 1950 do \ 1951 { \ 1952 result = gfc_expr_walker (&(NODE), exprfn, data); \ 1953 if (result) \ 1954 return result; \ 1955 } \ 1956 while (0) 1957#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue 1958 1959/* Walk expression *E, calling EXPRFN on each expression in it. */ 1960 1961int 1962gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data) 1963{ 1964 while (*e) 1965 { 1966 int walk_subtrees = 1; 1967 gfc_actual_arglist *a; 1968 gfc_ref *r; 1969 gfc_constructor *c; 1970 1971 int result = exprfn (e, &walk_subtrees, data); 1972 if (result) 1973 return result; 1974 if (walk_subtrees) 1975 switch ((*e)->expr_type) 1976 { 1977 case EXPR_OP: 1978 WALK_SUBEXPR ((*e)->value.op.op1); 1979 WALK_SUBEXPR_TAIL ((*e)->value.op.op2); 1980 break; 1981 case EXPR_FUNCTION: 1982 for (a = (*e)->value.function.actual; a; a = a->next) 1983 WALK_SUBEXPR (a->expr); 1984 break; 1985 case EXPR_COMPCALL: 1986 case EXPR_PPC: 1987 WALK_SUBEXPR ((*e)->value.compcall.base_object); 1988 for (a = (*e)->value.compcall.actual; a; a = a->next) 1989 WALK_SUBEXPR (a->expr); 1990 break; 1991 1992 case EXPR_STRUCTURE: 1993 case EXPR_ARRAY: 1994 for (c = gfc_constructor_first ((*e)->value.constructor); c; 1995 c = gfc_constructor_next (c)) 1996 { 1997 if (c->iterator == NULL) 1998 WALK_SUBEXPR (c->expr); 1999 else 2000 { 2001 iterator_level ++; 2002 WALK_SUBEXPR (c->expr); 2003 iterator_level --; 2004 WALK_SUBEXPR (c->iterator->var); 2005 WALK_SUBEXPR (c->iterator->start); 2006 WALK_SUBEXPR (c->iterator->end); 2007 WALK_SUBEXPR (c->iterator->step); 2008 } 2009 } 2010 2011 if ((*e)->expr_type != EXPR_ARRAY) 2012 break; 2013 2014 /* Fall through to the variable case in order to walk the 2015 reference. */ 2016 2017 case EXPR_SUBSTRING: 2018 case EXPR_VARIABLE: 2019 for (r = (*e)->ref; r; r = r->next) 2020 { 2021 gfc_array_ref *ar; 2022 int i; 2023 2024 switch (r->type) 2025 { 2026 case REF_ARRAY: 2027 ar = &r->u.ar; 2028 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT) 2029 { 2030 for (i=0; i< ar->dimen; i++) 2031 { 2032 WALK_SUBEXPR (ar->start[i]); 2033 WALK_SUBEXPR (ar->end[i]); 2034 WALK_SUBEXPR (ar->stride[i]); 2035 } 2036 } 2037 2038 break; 2039 2040 case REF_SUBSTRING: 2041 WALK_SUBEXPR (r->u.ss.start); 2042 WALK_SUBEXPR (r->u.ss.end); 2043 break; 2044 2045 case REF_COMPONENT: 2046 break; 2047 } 2048 } 2049 2050 default: 2051 break; 2052 } 2053 return 0; 2054 } 2055 return 0; 2056} 2057 2058#define WALK_SUBCODE(NODE) \ 2059 do \ 2060 { \ 2061 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \ 2062 if (result) \ 2063 return result; \ 2064 } \ 2065 while (0) 2066 2067/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN 2068 on each expression in it. If any of the hooks returns non-zero, that 2069 value is immediately returned. If the hook sets *WALK_SUBTREES to 0, 2070 no subcodes or subexpressions are traversed. */ 2071 2072int 2073gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, 2074 void *data) 2075{ 2076 for (; *c; c = &(*c)->next) 2077 { 2078 int walk_subtrees = 1; 2079 int result = codefn (c, &walk_subtrees, data); 2080 if (result) 2081 return result; 2082 2083 if (walk_subtrees) 2084 { 2085 gfc_code *b; 2086 gfc_actual_arglist *a; 2087 gfc_code *co; 2088 gfc_association_list *alist; 2089 bool saved_in_omp_workshare; 2090 2091 /* There might be statement insertions before the current code, 2092 which must not affect the expression walker. */ 2093 2094 co = *c; 2095 saved_in_omp_workshare = in_omp_workshare; 2096 2097 switch (co->op) 2098 { 2099 2100 case EXEC_BLOCK: 2101 WALK_SUBCODE (co->ext.block.ns->code); 2102 if (co->ext.block.assoc) 2103 { 2104 bool saved_in_assoc_list = in_assoc_list; 2105 2106 in_assoc_list = true; 2107 for (alist = co->ext.block.assoc; alist; alist = alist->next) 2108 WALK_SUBEXPR (alist->target); 2109 2110 in_assoc_list = saved_in_assoc_list; 2111 } 2112 2113 break; 2114 2115 case EXEC_DO: 2116 doloop_level ++; 2117 WALK_SUBEXPR (co->ext.iterator->var); 2118 WALK_SUBEXPR (co->ext.iterator->start); 2119 WALK_SUBEXPR (co->ext.iterator->end); 2120 WALK_SUBEXPR (co->ext.iterator->step); 2121 break; 2122 2123 case EXEC_CALL: 2124 case EXEC_ASSIGN_CALL: 2125 for (a = co->ext.actual; a; a = a->next) 2126 WALK_SUBEXPR (a->expr); 2127 break; 2128 2129 case EXEC_CALL_PPC: 2130 WALK_SUBEXPR (co->expr1); 2131 for (a = co->ext.actual; a; a = a->next) 2132 WALK_SUBEXPR (a->expr); 2133 break; 2134 2135 case EXEC_SELECT: 2136 WALK_SUBEXPR (co->expr1); 2137 for (b = co->block; b; b = b->block) 2138 { 2139 gfc_case *cp; 2140 for (cp = b->ext.block.case_list; cp; cp = cp->next) 2141 { 2142 WALK_SUBEXPR (cp->low); 2143 WALK_SUBEXPR (cp->high); 2144 } 2145 WALK_SUBCODE (b->next); 2146 } 2147 continue; 2148 2149 case EXEC_ALLOCATE: 2150 case EXEC_DEALLOCATE: 2151 { 2152 gfc_alloc *a; 2153 for (a = co->ext.alloc.list; a; a = a->next) 2154 WALK_SUBEXPR (a->expr); 2155 break; 2156 } 2157 2158 case EXEC_FORALL: 2159 case EXEC_DO_CONCURRENT: 2160 { 2161 gfc_forall_iterator *fa; 2162 for (fa = co->ext.forall_iterator; fa; fa = fa->next) 2163 { 2164 WALK_SUBEXPR (fa->var); 2165 WALK_SUBEXPR (fa->start); 2166 WALK_SUBEXPR (fa->end); 2167 WALK_SUBEXPR (fa->stride); 2168 } 2169 if (co->op == EXEC_FORALL) 2170 forall_level ++; 2171 break; 2172 } 2173 2174 case EXEC_OPEN: 2175 WALK_SUBEXPR (co->ext.open->unit); 2176 WALK_SUBEXPR (co->ext.open->file); 2177 WALK_SUBEXPR (co->ext.open->status); 2178 WALK_SUBEXPR (co->ext.open->access); 2179 WALK_SUBEXPR (co->ext.open->form); 2180 WALK_SUBEXPR (co->ext.open->recl); 2181 WALK_SUBEXPR (co->ext.open->blank); 2182 WALK_SUBEXPR (co->ext.open->position); 2183 WALK_SUBEXPR (co->ext.open->action); 2184 WALK_SUBEXPR (co->ext.open->delim); 2185 WALK_SUBEXPR (co->ext.open->pad); 2186 WALK_SUBEXPR (co->ext.open->iostat); 2187 WALK_SUBEXPR (co->ext.open->iomsg); 2188 WALK_SUBEXPR (co->ext.open->convert); 2189 WALK_SUBEXPR (co->ext.open->decimal); 2190 WALK_SUBEXPR (co->ext.open->encoding); 2191 WALK_SUBEXPR (co->ext.open->round); 2192 WALK_SUBEXPR (co->ext.open->sign); 2193 WALK_SUBEXPR (co->ext.open->asynchronous); 2194 WALK_SUBEXPR (co->ext.open->id); 2195 WALK_SUBEXPR (co->ext.open->newunit); 2196 break; 2197 2198 case EXEC_CLOSE: 2199 WALK_SUBEXPR (co->ext.close->unit); 2200 WALK_SUBEXPR (co->ext.close->status); 2201 WALK_SUBEXPR (co->ext.close->iostat); 2202 WALK_SUBEXPR (co->ext.close->iomsg); 2203 break; 2204 2205 case EXEC_BACKSPACE: 2206 case EXEC_ENDFILE: 2207 case EXEC_REWIND: 2208 case EXEC_FLUSH: 2209 WALK_SUBEXPR (co->ext.filepos->unit); 2210 WALK_SUBEXPR (co->ext.filepos->iostat); 2211 WALK_SUBEXPR (co->ext.filepos->iomsg); 2212 break; 2213 2214 case EXEC_INQUIRE: 2215 WALK_SUBEXPR (co->ext.inquire->unit); 2216 WALK_SUBEXPR (co->ext.inquire->file); 2217 WALK_SUBEXPR (co->ext.inquire->iomsg); 2218 WALK_SUBEXPR (co->ext.inquire->iostat); 2219 WALK_SUBEXPR (co->ext.inquire->exist); 2220 WALK_SUBEXPR (co->ext.inquire->opened); 2221 WALK_SUBEXPR (co->ext.inquire->number); 2222 WALK_SUBEXPR (co->ext.inquire->named); 2223 WALK_SUBEXPR (co->ext.inquire->name); 2224 WALK_SUBEXPR (co->ext.inquire->access); 2225 WALK_SUBEXPR (co->ext.inquire->sequential); 2226 WALK_SUBEXPR (co->ext.inquire->direct); 2227 WALK_SUBEXPR (co->ext.inquire->form); 2228 WALK_SUBEXPR (co->ext.inquire->formatted); 2229 WALK_SUBEXPR (co->ext.inquire->unformatted); 2230 WALK_SUBEXPR (co->ext.inquire->recl); 2231 WALK_SUBEXPR (co->ext.inquire->nextrec); 2232 WALK_SUBEXPR (co->ext.inquire->blank); 2233 WALK_SUBEXPR (co->ext.inquire->position); 2234 WALK_SUBEXPR (co->ext.inquire->action); 2235 WALK_SUBEXPR (co->ext.inquire->read); 2236 WALK_SUBEXPR (co->ext.inquire->write); 2237 WALK_SUBEXPR (co->ext.inquire->readwrite); 2238 WALK_SUBEXPR (co->ext.inquire->delim); 2239 WALK_SUBEXPR (co->ext.inquire->encoding); 2240 WALK_SUBEXPR (co->ext.inquire->pad); 2241 WALK_SUBEXPR (co->ext.inquire->iolength); 2242 WALK_SUBEXPR (co->ext.inquire->convert); 2243 WALK_SUBEXPR (co->ext.inquire->strm_pos); 2244 WALK_SUBEXPR (co->ext.inquire->asynchronous); 2245 WALK_SUBEXPR (co->ext.inquire->decimal); 2246 WALK_SUBEXPR (co->ext.inquire->pending); 2247 WALK_SUBEXPR (co->ext.inquire->id); 2248 WALK_SUBEXPR (co->ext.inquire->sign); 2249 WALK_SUBEXPR (co->ext.inquire->size); 2250 WALK_SUBEXPR (co->ext.inquire->round); 2251 break; 2252 2253 case EXEC_WAIT: 2254 WALK_SUBEXPR (co->ext.wait->unit); 2255 WALK_SUBEXPR (co->ext.wait->iostat); 2256 WALK_SUBEXPR (co->ext.wait->iomsg); 2257 WALK_SUBEXPR (co->ext.wait->id); 2258 break; 2259 2260 case EXEC_READ: 2261 case EXEC_WRITE: 2262 WALK_SUBEXPR (co->ext.dt->io_unit); 2263 WALK_SUBEXPR (co->ext.dt->format_expr); 2264 WALK_SUBEXPR (co->ext.dt->rec); 2265 WALK_SUBEXPR (co->ext.dt->advance); 2266 WALK_SUBEXPR (co->ext.dt->iostat); 2267 WALK_SUBEXPR (co->ext.dt->size); 2268 WALK_SUBEXPR (co->ext.dt->iomsg); 2269 WALK_SUBEXPR (co->ext.dt->id); 2270 WALK_SUBEXPR (co->ext.dt->pos); 2271 WALK_SUBEXPR (co->ext.dt->asynchronous); 2272 WALK_SUBEXPR (co->ext.dt->blank); 2273 WALK_SUBEXPR (co->ext.dt->decimal); 2274 WALK_SUBEXPR (co->ext.dt->delim); 2275 WALK_SUBEXPR (co->ext.dt->pad); 2276 WALK_SUBEXPR (co->ext.dt->round); 2277 WALK_SUBEXPR (co->ext.dt->sign); 2278 WALK_SUBEXPR (co->ext.dt->extra_comma); 2279 break; 2280 2281 case EXEC_OMP_PARALLEL: 2282 case EXEC_OMP_PARALLEL_DO: 2283 case EXEC_OMP_PARALLEL_DO_SIMD: 2284 case EXEC_OMP_PARALLEL_SECTIONS: 2285 2286 in_omp_workshare = false; 2287 2288 /* This goto serves as a shortcut to avoid code 2289 duplication or a larger if or switch statement. */ 2290 goto check_omp_clauses; 2291 2292 case EXEC_OMP_WORKSHARE: 2293 case EXEC_OMP_PARALLEL_WORKSHARE: 2294 2295 in_omp_workshare = true; 2296 2297 /* Fall through */ 2298 2299 case EXEC_OMP_DISTRIBUTE: 2300 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 2301 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 2302 case EXEC_OMP_DISTRIBUTE_SIMD: 2303 case EXEC_OMP_DO: 2304 case EXEC_OMP_DO_SIMD: 2305 case EXEC_OMP_SECTIONS: 2306 case EXEC_OMP_SINGLE: 2307 case EXEC_OMP_END_SINGLE: 2308 case EXEC_OMP_SIMD: 2309 case EXEC_OMP_TARGET: 2310 case EXEC_OMP_TARGET_DATA: 2311 case EXEC_OMP_TARGET_TEAMS: 2312 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 2313 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 2314 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2315 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 2316 case EXEC_OMP_TARGET_UPDATE: 2317 case EXEC_OMP_TASK: 2318 case EXEC_OMP_TEAMS: 2319 case EXEC_OMP_TEAMS_DISTRIBUTE: 2320 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 2321 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2322 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 2323 2324 /* Come to this label only from the 2325 EXEC_OMP_PARALLEL_* cases above. */ 2326 2327 check_omp_clauses: 2328 2329 if (co->ext.omp_clauses) 2330 { 2331 gfc_omp_namelist *n; 2332 static int list_types[] 2333 = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND, 2334 OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM }; 2335 size_t idx; 2336 WALK_SUBEXPR (co->ext.omp_clauses->if_expr); 2337 WALK_SUBEXPR (co->ext.omp_clauses->final_expr); 2338 WALK_SUBEXPR (co->ext.omp_clauses->num_threads); 2339 WALK_SUBEXPR (co->ext.omp_clauses->chunk_size); 2340 WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr); 2341 WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr); 2342 WALK_SUBEXPR (co->ext.omp_clauses->num_teams); 2343 WALK_SUBEXPR (co->ext.omp_clauses->device); 2344 WALK_SUBEXPR (co->ext.omp_clauses->thread_limit); 2345 WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size); 2346 for (idx = 0; 2347 idx < sizeof (list_types) / sizeof (list_types[0]); 2348 idx++) 2349 for (n = co->ext.omp_clauses->lists[list_types[idx]]; 2350 n; n = n->next) 2351 WALK_SUBEXPR (n->expr); 2352 } 2353 break; 2354 default: 2355 break; 2356 } 2357 2358 WALK_SUBEXPR (co->expr1); 2359 WALK_SUBEXPR (co->expr2); 2360 WALK_SUBEXPR (co->expr3); 2361 WALK_SUBEXPR (co->expr4); 2362 for (b = co->block; b; b = b->block) 2363 { 2364 WALK_SUBEXPR (b->expr1); 2365 WALK_SUBEXPR (b->expr2); 2366 WALK_SUBCODE (b->next); 2367 } 2368 2369 if (co->op == EXEC_FORALL) 2370 forall_level --; 2371 2372 if (co->op == EXEC_DO) 2373 doloop_level --; 2374 2375 in_omp_workshare = saved_in_omp_workshare; 2376 } 2377 } 2378 return 0; 2379} 2380