gcc/fortran/frontend-passes.c

   1 /* Pass manager for Fortran front end.
   2    Copyright (C) 2010, 2011 Free Software Foundation, Inc.
   3    Contributed by Thomas König.
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "gfortran.h"
  24 #include "arith.h"
  25 #include "flags.h"
  26 #include "dependency.h"
  27 #include "constructor.h"
  28 #include "opts.h"
  29
  30 /* Forward declarations.  */
  31
  32 static void strip_function_call (gfc_expr *);
  33 static void optimize_namespace (gfc_namespace *);
  34 static void optimize_assignment (gfc_code *);
  35 static bool optimize_op (gfc_expr *);
  36 static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
  37 static bool optimize_trim (gfc_expr *);
  38 static bool optimize_lexical_comparison (gfc_expr *);
  39 static void optimize_minmaxloc (gfc_expr **);
  40
  41 /* How deep we are inside an argument list.  */
  42
  43 static int count_arglist;
  44
  45 /* Pointer to an array of gfc_expr ** we operate on, plus its size
  46    and counter.  */
  47
  48 static gfc_expr ***expr_array;
  49 static int expr_size, expr_count;
  50
  51 /* Pointer to the gfc_code we currently work on - to be able to insert
  52    a block before the statement.  */
  53
  54 static gfc_code **current_code;
  55
  56 /* Pointer to the block to be inserted, and the statement we are
  57    changing within the block.  */
  58
  59 static gfc_code *inserted_block, **changed_statement;
  60
  61 /* The namespace we are currently dealing with.  */
  62
  63 static gfc_namespace *current_ns;
  64
  65 /* If we are within any forall loop.  */
  66
  67 static int forall_level;
  68
  69 /* Keep track of whether we are within an OMP workshare.  */
  70
  71 static bool in_omp_workshare;
  72
  73 /* Entry point - run all passes for a namespace.  So far, only an
  74    optimization pass is run.  */
  75
  76 void
  77 gfc_run_passes (gfc_namespace *ns)
  78 {
  79   if (gfc_option.flag_frontend_optimize)
  80     {
  81       expr_size = 20;
  82       expr_array = XNEWVEC(gfc_expr **, expr_size);
  83
  84       optimize_namespace (ns);
  85       if (gfc_option.dump_fortran_optimized)
  86         gfc_dump_parse_tree (ns, stdout);
  87
  88       XDELETEVEC (expr_array);
  89     }
  90 }
  91
  92 /* Callback for each gfc_code node invoked through gfc_code_walker
  93    from optimize_namespace.  */
  94
  95 static int
  96 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
  97                void *data ATTRIBUTE_UNUSED)
  98 {
  99
 100   gfc_exec_op op;
 101
 102   op = (*c)->op;
 103
 104   if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
 105       || op == EXEC_CALL_PPC)
 106     count_arglist = 1;
 107   else
 108     count_arglist = 0;
 109
 110   if (op == EXEC_ASSIGN)
 111     optimize_assignment (*c);
 112   return 0;
 113 }
 114
 115 /* Callback for each gfc_expr node invoked through gfc_code_walker
 116    from optimize_namespace.  */
 117
 118 static int
 119 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 120                void *data ATTRIBUTE_UNUSED)
 121 {
 122   bool function_expr;
 123
 124   if ((*e)->expr_type == EXPR_FUNCTION)
 125     {
 126       count_arglist ++;
 127       function_expr = true;
 128     }
 129   else
 130     function_expr = false;
 131
 132   if (optimize_trim (*e))
 133     gfc_simplify_expr (*e, 0);
 134
 135   if (optimize_lexical_comparison (*e))
 136     gfc_simplify_expr (*e, 0);
 137
 138   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
 139     gfc_simplify_expr (*e, 0);
 140
 141   if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
 142     switch ((*e)->value.function.isym->id)
 143       {
 144       case GFC_ISYM_MINLOC:
 145       case GFC_ISYM_MAXLOC:
 146         optimize_minmaxloc (e);
 147         break;
 148       default:
 149         break;
 150       }
 151
 152   if (function_expr)
 153     count_arglist --;
 154
 155   return 0;
 156 }
 157
 158
 159 /* Callback function for common function elimination, called from cfe_expr_0.
 160    Put all eligible function expressions into expr_array.  */
 161
 162 static int
 163 cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
 164           void *data ATTRIBUTE_UNUSED)
 165 {
 166
 167   if ((*e)->expr_type != EXPR_FUNCTION)
 168     return 0;
 169
 170   /* We don't do character functions with unknown charlens.  */
 171   if ((*e)->ts.type == BT_CHARACTER
 172       && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
 173           || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
 174     return 0;
 175
 176   /* We don't do function elimination within FORALL statements, it can
 177      lead to wrong-code in certain circumstances.  */
 178
 179   if (forall_level > 0)
 180     return 0;
 181
 182   /* If we don't know the shape at compile time, we create an allocatable
 183      temporary variable to hold the intermediate result, but only if
 184      allocation on assignment is active.  */
 185
 186   if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
 187     return 0;
 188
 189   /* Skip the test for pure functions if -faggressive-function-elimination
 190      is specified.  */
 191   if ((*e)->value.function.esym)
 192     {
 193       /* Don't create an array temporary for elemental functions.  */
 194       if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
 195         return 0;
 196
 197       /* Only eliminate potentially impure functions if the
 198          user specifically requested it.  */
 199       if (!gfc_option.flag_aggressive_function_elimination
 200           && !(*e)->value.function.esym->attr.pure
 201           && !(*e)->value.function.esym->attr.implicit_pure)
 202         return 0;
 203     }
 204
 205   if ((*e)->value.function.isym)
 206     {
 207       /* Conversions are handled on the fly by the middle end,
 208          transpose during trans-* stages and TRANSFER by the middle end.  */
 209       if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
 210           || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
 211           || gfc_inline_intrinsic_function_p (*e))
 212         return 0;
 213
 214       /* Don't create an array temporary for elemental functions,
 215          as this would be wasteful of memory.
 216          FIXME: Create a scalar temporary during scalarization.  */
 217       if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
 218         return 0;
 219
 220       if (!(*e)->value.function.isym->pure)
 221         return 0;
 222     }
 223
 224   if (expr_count >= expr_size)
 225     {
 226       expr_size += expr_size;
 227       expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
 228     }
 229   expr_array[expr_count] = e;
 230   expr_count ++;
 231   return 0;
 232 }
 233
 234 /* Returns a new expression (a variable) to be used in place of the old one,
 235    with an an assignment statement before the current statement to set
 236    the value of the variable. Creates a new BLOCK for the statement if
 237    that hasn't already been done and puts the statement, plus the
 238    newly created variables, in that block.  */
 239
 240 static gfc_expr*
 241 create_var (gfc_expr * e)
 242 {
 243   char name[GFC_MAX_SYMBOL_LEN +1];
 244   static int num = 1;
 245   gfc_symtree *symtree;
 246   gfc_symbol *symbol;
 247   gfc_expr *result;
 248   gfc_code *n;
 249   gfc_namespace *ns;
 250   int i;
 251
 252   /* If the block hasn't already been created, do so.  */
 253   if (inserted_block == NULL)
 254     {
 255       inserted_block = XCNEW (gfc_code);
 256       inserted_block->op = EXEC_BLOCK;
 257       inserted_block->loc = (*current_code)->loc;
 258       ns = gfc_build_block_ns (current_ns);
 259       inserted_block->ext.block.ns = ns;
 260       inserted_block->ext.block.assoc = NULL;
 261
 262       ns->code = *current_code;
 263       inserted_block->next = (*current_code)->next;
 264       changed_statement = &(inserted_block->ext.block.ns->code);
 265       (*current_code)->next = NULL;
 266       /* Insert the BLOCK at the right position.  */
 267       *current_code = inserted_block;
 268       ns->parent = current_ns;
 269     }
 270   else
 271     ns = inserted_block->ext.block.ns;
 272
 273   sprintf(name, "__var_%d",num++);
 274   if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
 275     gcc_unreachable ();
 276
 277   symbol = symtree->n.sym;
 278   symbol->ts = e->ts;
 279
 280   if (e->rank > 0)
 281     {
 282       symbol->as = gfc_get_array_spec ();
 283       symbol->as->rank = e->rank;
 284
 285       if (e->shape == NULL)
 286         {
 287           /* We don't know the shape at compile time, so we use an
 288              allocatable. */
 289           symbol->as->type = AS_DEFERRED;
 290           symbol->attr.allocatable = 1;
 291         }
 292       else
 293         {
 294           symbol->as->type = AS_EXPLICIT;
 295           /* Copy the shape.  */
 296           for (i=0; i<e->rank; i++)
 297             {
 298               gfc_expr *p, *q;
 299
 300               p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 301                                          &(e->where));
 302               mpz_set_si (p->value.integer, 1);
 303               symbol->as->lower[i] = p;
 304
 305               q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
 306                                          &(e->where));
 307               mpz_set (q->value.integer, e->shape[i]);
 308               symbol->as->upper[i] = q;
 309             }
 310         }
 311     }
 312
 313   symbol->attr.flavor = FL_VARIABLE;
 314   symbol->attr.referenced = 1;
 315   symbol->attr.dimension = e->rank > 0;
 316   gfc_commit_symbol (symbol);
 317
 318   result = gfc_get_expr ();
 319   result->expr_type = EXPR_VARIABLE;
 320   result->ts = e->ts;
 321   result->rank = e->rank;
 322   result->shape = gfc_copy_shape (e->shape, e->rank);
 323   result->symtree = symtree;
 324   result->where = e->where;
 325   if (e->rank > 0)
 326     {
 327       result->ref = gfc_get_ref ();
 328       result->ref->type = REF_ARRAY;
 329       result->ref->u.ar.type = AR_FULL;
 330       result->ref->u.ar.where = e->where;
 331       result->ref->u.ar.as = symbol->ts.type == BT_CLASS
 332                              ? CLASS_DATA (symbol)->as : symbol->as;
 333       if (gfc_option.warn_array_temp)
 334         gfc_warning ("Creating array temporary at %L", &(e->where));
 335     }
 336
 337   /* Generate the new assignment.  */
 338   n = XCNEW (gfc_code);
 339   n->op = EXEC_ASSIGN;
 340   n->loc = (*current_code)->loc;
 341   n->next = *changed_statement;
 342   n->expr1 = gfc_copy_expr (result);
 343   n->expr2 = e;
 344   *changed_statement = n;
 345
 346   return result;
 347 }
 348
 349 /* Warn about function elimination.  */
 350
 351 static void
 352 warn_function_elimination (gfc_expr *e)
 353 {
 354   if (e->expr_type != EXPR_FUNCTION)
 355     return;
 356   if (e->value.function.esym)
 357     gfc_warning ("Removing call to function '%s' at %L",
 358                  e->value.function.esym->name, &(e->where));
 359   else if (e->value.function.isym)
 360     gfc_warning ("Removing call to function '%s' at %L",
 361                  e->value.function.isym->name, &(e->where));
 362 }
 363 /* Callback function for the code walker for doing common function
 364    elimination.  This builds up the list of functions in the expression
 365    and goes through them to detect duplicates, which it then replaces
 366    by variables.  */
 367
 368 static int
 369 cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
 370           void *data ATTRIBUTE_UNUSED)
 371 {
 372   int i,j;
 373   gfc_expr *newvar;
 374
 375   /* Don't do this optimization within OMP workshare. */
 376
 377   if (in_omp_workshare)
 378     {
 379       *walk_subtrees = 0;
 380       return 0;
 381     }
 382
 383   expr_count = 0;
 384
 385   gfc_expr_walker (e, cfe_register_funcs, NULL);
 386
 387   /* Walk through all the functions.  */
 388
 389   for (i=1; i<expr_count; i++)
 390     {
 391       /* Skip if the function has been replaced by a variable already.  */
 392       if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
 393         continue;
 394
 395       newvar = NULL;
 396       for (j=0; j<i; j++)
 397         {
 398           if (gfc_dep_compare_functions(*(expr_array[i]),
 399                                         *(expr_array[j]), true) == 0)
 400             {
 401               if (newvar == NULL)
 402                 newvar = create_var (*(expr_array[i]));
 403
 404               if (gfc_option.warn_function_elimination)
 405                 warn_function_elimination (*(expr_array[j]));
 406
 407               free (*(expr_array[j]));
 408               *(expr_array[j]) = gfc_copy_expr (newvar);
 409             }
 410         }
 411       if (newvar)
 412         *(expr_array[i]) = newvar;
 413     }
 414
 415   /* We did all the necessary walking in this function.  */
 416   *walk_subtrees = 0;
 417   return 0;
 418 }
 419
 420 /* Callback function for common function elimination, called from
 421    gfc_code_walker.  This keeps track of the current code, in order
 422    to insert statements as needed.  */
 423
 424 static int
 425 cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 426           void *data ATTRIBUTE_UNUSED)
 427 {
 428   current_code = c;
 429   inserted_block = NULL;
 430   changed_statement = NULL;
 431   return 0;
 432 }
 433
 434 /* Dummy function for expression call back, for use when we
 435    really don't want to do any walking.  */
 436
 437 static int
 438 dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
 439                      void *data ATTRIBUTE_UNUSED)
 440 {
 441   *walk_subtrees = 0;
 442   return 0;
 443 }
 444
 445 /* Code callback function for converting
 446    do while(a)
 447    end do
 448    into the equivalent
 449    do
 450      if (.not. a) exit
 451    end do
 452    This is because common function elimination would otherwise place the
 453    temporary variables outside the loop.  */
 454
 455 static int
 456 convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
 457                   void *data ATTRIBUTE_UNUSED)
 458 {
 459   gfc_code *co = *c;
 460   gfc_code *c_if1, *c_if2, *c_exit;
 461   gfc_code *loopblock;
 462   gfc_expr *e_not, *e_cond;
 463
 464   if (co->op != EXEC_DO_WHILE)
 465     return 0;
 466
 467   if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
 468     return 0;
 469
 470   e_cond = co->expr1;
 471
 472   /* Generate the condition of the if statement, which is .not. the original
 473      statement.  */
 474   e_not = gfc_get_expr ();
 475   e_not->ts = e_cond->ts;
 476   e_not->where = e_cond->where;
 477   e_not->expr_type = EXPR_OP;
 478   e_not->value.op.op = INTRINSIC_NOT;
 479   e_not->value.op.op1 = e_cond;
 480
 481   /* Generate the EXIT statement.  */
 482   c_exit = XCNEW (gfc_code);
 483   c_exit->op = EXEC_EXIT;
 484   c_exit->ext.which_construct = co;
 485   c_exit->loc = co->loc;
 486
 487   /* Generate the IF statement.  */
 488   c_if2 = XCNEW (gfc_code);
 489   c_if2->op = EXEC_IF;
 490   c_if2->expr1 = e_not;
 491   c_if2->next = c_exit;
 492   c_if2->loc = co->loc;
 493
 494   /* ... plus the one to chain it to.  */
 495   c_if1 = XCNEW (gfc_code);
 496   c_if1->op = EXEC_IF;
 497   c_if1->block = c_if2;
 498   c_if1->loc = co->loc;
 499
 500   /* Make the DO WHILE loop into a DO block by replacing the condition
 501      with a true constant.  */
 502   co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
 503
 504   /* Hang the generated if statement into the loop body.  */
 505
 506   loopblock = co->block->next;
 507   co->block->next = c_if1;
 508   c_if1->next = loopblock;
 509
 510   return 0;
 511 }
 512
 513 /* Optimize a namespace, including all contained namespaces.  */
 514
 515 static void
 516 optimize_namespace (gfc_namespace *ns)
 517 {
 518
 519   current_ns = ns;
 520   forall_level = 0;
 521   in_omp_workshare = false;
 522
 523   gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
 524   gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
 525   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 526
 527   /* BLOCKs are handled in the expression walker below.  */
 528   for (ns = ns->contained; ns; ns = ns->sibling)
 529     {
 530       if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
 531         optimize_namespace (ns);
 532     }
 533 }
 534
 535 /* Replace code like
 536    a = matmul(b,c) + d
 537    with
 538    a = matmul(b,c) ;   a = a + d
 539    where the array function is not elemental and not allocatable
 540    and does not depend on the left-hand side.
 541 */
 542
 543 static bool
 544 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
 545 {
 546   gfc_expr *e;
 547
 548   e = *rhs;
 549   if (e->expr_type == EXPR_OP)
 550     {
 551       switch (e->value.op.op)
 552         {
 553           /* Unary operators and exponentiation: Only look at a single
 554              operand.  */
 555         case INTRINSIC_NOT:
 556         case INTRINSIC_UPLUS:
 557         case INTRINSIC_UMINUS:
 558         case INTRINSIC_PARENTHESES:
 559         case INTRINSIC_POWER:
 560           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 561             return true;
 562           break;
 563
 564         default:
 565           /* Binary operators.  */
 566           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 567             return true;
 568
 569           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 570             return true;
 571
 572           break;
 573         }
 574     }
 575   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 576            && ! (e->value.function.esym
 577                  && (e->value.function.esym->attr.elemental
 578                      || e->value.function.esym->attr.allocatable
 579                      || e->value.function.esym->ts.type != c->expr1->ts.type
 580                      || e->value.function.esym->ts.kind != c->expr1->ts.kind))
 581            && ! (e->value.function.isym
 582                  && (e->value.function.isym->elemental
 583                      || e->ts.type != c->expr1->ts.type
 584                      || e->ts.kind != c->expr1->ts.kind))
 585            && ! gfc_inline_intrinsic_function_p (e))
 586     {
 587
 588       gfc_code *n;
 589       gfc_expr *new_expr;
 590
 591       /* Insert a new assignment statement after the current one.  */
 592       n = XCNEW (gfc_code);
 593       n->op = EXEC_ASSIGN;
 594       n->loc = c->loc;
 595       n->next = c->next;
 596       c->next = n;
 597
 598       n->expr1 = gfc_copy_expr (c->expr1);
 599       n->expr2 = c->expr2;
 600       new_expr = gfc_copy_expr (c->expr1);
 601       c->expr2 = e;
 602       *rhs = new_expr;
 603
 604       return true;
 605
 606     }
 607
 608   /* Nothing to optimize.  */
 609   return false;
 610 }
 611
 612 /* Remove unneeded TRIMs at the end of expressions.  */
 613
 614 static bool
 615 remove_trim (gfc_expr *rhs)
 616 {
 617   bool ret;
 618
 619   ret = false;
 620
 621   /* Check for a // b // trim(c).  Looping is probably not
 622      necessary because the parser usually generates
 623      (// (// a b ) trim(c) ) , but better safe than sorry.  */
 624
 625   while (rhs->expr_type == EXPR_OP
 626          && rhs->value.op.op == INTRINSIC_CONCAT)
 627     rhs = rhs->value.op.op2;
 628
 629   while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
 630          && rhs->value.function.isym->id == GFC_ISYM_TRIM)
 631     {
 632       strip_function_call (rhs);
 633       /* Recursive call to catch silly stuff like trim ( a // trim(b)).  */
 634       remove_trim (rhs);
 635       ret = true;
 636     }
 637
 638   return ret;
 639 }
 640
 641 /* Optimizations for an assignment.  */
 642
 643 static void
 644 optimize_assignment (gfc_code * c)
 645 {
 646   gfc_expr *lhs, *rhs;
 647
 648   lhs = c->expr1;
 649   rhs = c->expr2;
 650
 651   /* Optimize away a = trim(b), where a is a character variable.  */
 652
 653   if (lhs->ts.type == BT_CHARACTER)
 654     remove_trim (rhs);
 655
 656   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 657     optimize_binop_array_assignment (c, &rhs, false);
 658 }
 659
 660
 661 /* Remove an unneeded function call, modifying the expression.
 662    This replaces the function call with the value of its
 663    first argument.  The rest of the argument list is freed.  */
 664
 665 static void
 666 strip_function_call (gfc_expr *e)
 667 {
 668   gfc_expr *e1;
 669   gfc_actual_arglist *a;
 670
 671   a = e->value.function.actual;
 672
 673   /* We should have at least one argument.  */
 674   gcc_assert (a->expr != NULL);
 675
 676   e1 = a->expr;
 677
 678   /* Free the remaining arglist, if any.  */
 679   if (a->next)
 680     gfc_free_actual_arglist (a->next);
 681
 682   /* Graft the argument expression onto the original function.  */
 683   *e = *e1;
 684   free (e1);
 685
 686 }
 687
 688 /* Optimization of lexical comparison functions.  */
 689
 690 static bool
 691 optimize_lexical_comparison (gfc_expr *e)
 692 {
 693   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
 694     return false;
 695
 696   switch (e->value.function.isym->id)
 697     {
 698     case GFC_ISYM_LLE:
 699       return optimize_comparison (e, INTRINSIC_LE);
 700
 701     case GFC_ISYM_LGE:
 702       return optimize_comparison (e, INTRINSIC_GE);
 703
 704     case GFC_ISYM_LGT:
 705       return optimize_comparison (e, INTRINSIC_GT);
 706
 707     case GFC_ISYM_LLT:
 708       return optimize_comparison (e, INTRINSIC_LT);
 709
 710     default:
 711       break;
 712     }
 713   return false;
 714 }
 715
 716 /* Recursive optimization of operators.  */
 717
 718 static bool
 719 optimize_op (gfc_expr *e)
 720 {
 721   gfc_intrinsic_op op = e->value.op.op;
 722
 723   switch (op)
 724     {
 725     case INTRINSIC_EQ:
 726     case INTRINSIC_EQ_OS:
 727     case INTRINSIC_GE:
 728     case INTRINSIC_GE_OS:
 729     case INTRINSIC_LE:
 730     case INTRINSIC_LE_OS:
 731     case INTRINSIC_NE:
 732     case INTRINSIC_NE_OS:
 733     case INTRINSIC_GT:
 734     case INTRINSIC_GT_OS:
 735     case INTRINSIC_LT:
 736     case INTRINSIC_LT_OS:
 737       return optimize_comparison (e, op);
 738
 739     default:
 740       break;
 741     }
 742
 743   return false;
 744 }
 745
 746 /* Optimize expressions for equality.  */
 747
 748 static bool
 749 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 750 {
 751   gfc_expr *op1, *op2;
 752   bool change;
 753   int eq;
 754   bool result;
 755   gfc_actual_arglist *firstarg, *secondarg;
 756
 757   if (e->expr_type == EXPR_OP)
 758     {
 759       firstarg = NULL;
 760       secondarg = NULL;
 761       op1 = e->value.op.op1;
 762       op2 = e->value.op.op2;
 763     }
 764   else if (e->expr_type == EXPR_FUNCTION)
 765     {
 766       /* One of the lexical comparision functions.  */
 767       firstarg = e->value.function.actual;
 768       secondarg = firstarg->next;
 769       op1 = firstarg->expr;
 770       op2 = secondarg->expr;
 771     }
 772   else
 773     gcc_unreachable ();
 774
 775   /* Strip off unneeded TRIM calls from string comparisons.  */
 776
 777   change = remove_trim (op1);
 778
 779   if (remove_trim (op2))
 780     change = true;
 781
 782   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 783   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 784      handles them well). However, there are also cases that need a non-scalar
 785      argument. For example the any intrinsic. See PR 45380.  */
 786   if (e->rank > 0)
 787     return change;
 788
 789   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 790
 791   if (flag_finite_math_only
 792       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 793           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 794     {
 795       eq = gfc_dep_compare_expr (op1, op2);
 796       if (eq <= -2)
 797         {
 798           /* Replace A // B < A // C with B < C, and A // B < C // B
 799              with A < C.  */
 800           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 801               && op1->value.op.op == INTRINSIC_CONCAT
 802               && op2->value.op.op == INTRINSIC_CONCAT)
 803             {
 804               gfc_expr *op1_left = op1->value.op.op1;
 805               gfc_expr *op2_left = op2->value.op.op1;
 806               gfc_expr *op1_right = op1->value.op.op2;
 807               gfc_expr *op2_right = op2->value.op.op2;
 808
 809               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 810                 {
 811                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 812
 813                   if (op1_left->expr_type == EXPR_CONSTANT
 814                         && op2_left->expr_type == EXPR_CONSTANT
 815                         && op1_left->value.character.length
 816                            != op2_left->value.character.length)
 817                     return change;
 818                   else
 819                     {
 820                       free (op1_left);
 821                       free (op2_left);
 822                       if (firstarg)
 823                         {
 824                           firstarg->expr = op1_right;
 825                           secondarg->expr = op2_right;
 826                         }
 827                       else
 828                         {
 829                           e->value.op.op1 = op1_right;
 830                           e->value.op.op2 = op2_right;
 831                         }
 832                       optimize_comparison (e, op);
 833                       return true;
 834                     }
 835                 }
 836               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 837                 {
 838                   free (op1_right);
 839                   free (op2_right);
 840                   if (firstarg)
 841                     {
 842                       firstarg->expr = op1_left;
 843                       secondarg->expr = op2_left;
 844                     }
 845                   else
 846                     {
 847                       e->value.op.op1 = op1_left;
 848                       e->value.op.op2 = op2_left;
 849                     }
 850
 851                   optimize_comparison (e, op);
 852                   return true;
 853                 }
 854             }
 855         }
 856       else
 857         {
 858           /* eq can only be -1, 0 or 1 at this point.  */
 859           switch (op)
 860             {
 861             case INTRINSIC_EQ:
 862             case INTRINSIC_EQ_OS:
 863               result = eq == 0;
 864               break;
 865
 866             case INTRINSIC_GE:
 867             case INTRINSIC_GE_OS:
 868               result = eq >= 0;
 869               break;
 870
 871             case INTRINSIC_LE:
 872             case INTRINSIC_LE_OS:
 873               result = eq <= 0;
 874               break;
 875
 876             case INTRINSIC_NE:
 877             case INTRINSIC_NE_OS:
 878               result = eq != 0;
 879               break;
 880
 881             case INTRINSIC_GT:
 882             case INTRINSIC_GT_OS:
 883               result = eq > 0;
 884               break;
 885
 886             case INTRINSIC_LT:
 887             case INTRINSIC_LT_OS:
 888               result = eq < 0;
 889               break;
 890
 891             default:
 892               gfc_internal_error ("illegal OP in optimize_comparison");
 893               break;
 894             }
 895
 896           /* Replace the expression by a constant expression.  The typespec
 897              and where remains the way it is.  */
 898           free (op1);
 899           free (op2);
 900           e->expr_type = EXPR_CONSTANT;
 901           e->value.logical = result;
 902           return true;
 903         }
 904     }
 905
 906   return change;
 907 }
 908
 909 /* Optimize a trim function by replacing it with an equivalent substring
 910    involving a call to len_trim.  This only works for expressions where
 911    variables are trimmed.  Return true if anything was modified.  */
 912
 913 static bool
 914 optimize_trim (gfc_expr *e)
 915 {
 916   gfc_expr *a;
 917   gfc_ref *ref;
 918   gfc_expr *fcn;
 919   gfc_actual_arglist *actual_arglist, *next;
 920   gfc_ref **rr = NULL;
 921
 922   /* Don't do this optimization within an argument list, because
 923      otherwise aliasing issues may occur.  */
 924
 925   if (count_arglist != 1)
 926     return false;
 927
 928   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
 929       || e->value.function.isym == NULL
 930       || e->value.function.isym->id != GFC_ISYM_TRIM)
 931     return false;
 932
 933   a = e->value.function.actual->expr;
 934
 935   if (a->expr_type != EXPR_VARIABLE)
 936     return false;
 937
 938   /* Follow all references to find the correct place to put the newly
 939      created reference.  FIXME:  Also handle substring references and
 940      array references.  Array references cause strange regressions at
 941      the moment.  */
 942
 943   if (a->ref)
 944     {
 945       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
 946         {
 947           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
 948             return false;
 949         }
 950     }
 951
 952   strip_function_call (e);
 953
 954   if (e->ref == NULL)
 955     rr = &(e->ref);
 956
 957   /* Create the reference.  */
 958
 959   ref = gfc_get_ref ();
 960   ref->type = REF_SUBSTRING;
 961
 962   /* Set the start of the reference.  */
 963
 964   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 965
 966   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 967
 968   fcn = gfc_get_expr ();
 969   fcn->expr_type = EXPR_FUNCTION;
 970   fcn->value.function.isym =
 971     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
 972   actual_arglist = gfc_get_actual_arglist ();
 973   actual_arglist->expr = gfc_copy_expr (e);
 974   next = gfc_get_actual_arglist ();
 975   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 976                                  gfc_default_integer_kind);
 977   actual_arglist->next = next;
 978   fcn->value.function.actual = actual_arglist;
 979
 980   /* Set the end of the reference to the call to len_trim.  */
 981
 982   ref->u.ss.end = fcn;
 983   gcc_assert (*rr == NULL);
 984   *rr = ref;
 985   return true;
 986 }
 987
 988 /* Optimize minloc(b), where b is rank 1 array, into
 989    (/ minloc(b, dim=1) /), and similarly for maxloc,
 990    as the latter forms are expanded inline.  */
 991
 992 static void
 993 optimize_minmaxloc (gfc_expr **e)
 994 {
 995   gfc_expr *fn = *e;
 996   gfc_actual_arglist *a;
 997   char *name, *p;
 998
 999   if (fn->rank != 1
1000       || fn->value.function.actual == NULL
1001       || fn->value.function.actual->expr == NULL
1002       || fn->value.function.actual->expr->rank != 1)
1003     return;
1004
1005   *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
1006   (*e)->shape = fn->shape;
1007   fn->rank = 0;
1008   fn->shape = NULL;
1009   gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
1010
1011   name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
1012   strcpy (name, fn->value.function.name);
1013   p = strstr (name, "loc0");
1014   p[3] = '1';
1015   fn->value.function.name = gfc_get_string (name);
1016   if (fn->value.function.actual->next)
1017     {
1018       a = fn->value.function.actual->next;
1019       gcc_assert (a->expr == NULL);
1020     }
1021   else
1022     {
1023       a = gfc_get_actual_arglist ();
1024       fn->value.function.actual->next = a;
1025     }
1026   a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
1027                                    &fn->where);
1028   mpz_set_ui (a->expr->value.integer, 1);
1029 }
1030
1031 #define WALK_SUBEXPR(NODE) \
1032   do                                                    \
1033     {                                                   \
1034       result = gfc_expr_walker (&(NODE), exprfn, data); \
1035       if (result)                                       \
1036         return result;                                  \
1037     }                                                   \
1038   while (0)
1039 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1040
1041 /* Walk expression *E, calling EXPRFN on each expression in it.  */
1042
1043 int
1044 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
1045 {
1046   while (*e)
1047     {
1048       int walk_subtrees = 1;
1049       gfc_actual_arglist *a;
1050       gfc_ref *r;
1051       gfc_constructor *c;
1052
1053       int result = exprfn (e, &walk_subtrees, data);
1054       if (result)
1055         return result;
1056       if (walk_subtrees)
1057         switch ((*e)->expr_type)
1058           {
1059           case EXPR_OP:
1060             WALK_SUBEXPR ((*e)->value.op.op1);
1061             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
1062             break;
1063           case EXPR_FUNCTION:
1064             for (a = (*e)->value.function.actual; a; a = a->next)
1065               WALK_SUBEXPR (a->expr);
1066             break;
1067           case EXPR_COMPCALL:
1068           case EXPR_PPC:
1069             WALK_SUBEXPR ((*e)->value.compcall.base_object);
1070             for (a = (*e)->value.compcall.actual; a; a = a->next)
1071               WALK_SUBEXPR (a->expr);
1072             break;
1073
1074           case EXPR_STRUCTURE:
1075           case EXPR_ARRAY:
1076             for (c = gfc_constructor_first ((*e)->value.constructor); c;
1077                  c = gfc_constructor_next (c))
1078               {
1079                 WALK_SUBEXPR (c->expr);
1080                 if (c->iterator != NULL)
1081                   {
1082                     WALK_SUBEXPR (c->iterator->var);
1083                     WALK_SUBEXPR (c->iterator->start);
1084                     WALK_SUBEXPR (c->iterator->end);
1085                     WALK_SUBEXPR (c->iterator->step);
1086                   }
1087               }
1088
1089             if ((*e)->expr_type != EXPR_ARRAY)
1090               break;
1091
1092             /* Fall through to the variable case in order to walk the
1093                reference.  */
1094
1095           case EXPR_SUBSTRING:
1096           case EXPR_VARIABLE:
1097             for (r = (*e)->ref; r; r = r->next)
1098               {
1099                 gfc_array_ref *ar;
1100                 int i;
1101
1102                 switch (r->type)
1103                   {
1104                   case REF_ARRAY:
1105                     ar = &r->u.ar;
1106                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
1107                       {
1108                         for (i=0; i< ar->dimen; i++)
1109                           {
1110                             WALK_SUBEXPR (ar->start[i]);
1111                             WALK_SUBEXPR (ar->end[i]);
1112                             WALK_SUBEXPR (ar->stride[i]);
1113                           }
1114                       }
1115
1116                     break;
1117
1118                   case REF_SUBSTRING:
1119                     WALK_SUBEXPR (r->u.ss.start);
1120                     WALK_SUBEXPR (r->u.ss.end);
1121                     break;
1122
1123                   case REF_COMPONENT:
1124                     break;
1125                   }
1126               }
1127
1128           default:
1129             break;
1130           }
1131       return 0;
1132     }
1133   return 0;
1134 }
1135
1136 #define WALK_SUBCODE(NODE) \
1137   do                                                            \
1138     {                                                           \
1139       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1140       if (result)                                               \
1141         return result;                                          \
1142     }                                                           \
1143   while (0)
1144
1145 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1146    on each expression in it.  If any of the hooks returns non-zero, that
1147    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
1148    no subcodes or subexpressions are traversed.  */
1149
1150 int
1151 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
1152                  void *data)
1153 {
1154   for (; *c; c = &(*c)->next)
1155     {
1156       int walk_subtrees = 1;
1157       int result = codefn (c, &walk_subtrees, data);
1158       if (result)
1159         return result;
1160
1161       if (walk_subtrees)
1162         {
1163           gfc_code *b;
1164           gfc_actual_arglist *a;
1165           gfc_code *co;
1166           gfc_association_list *alist;
1167           bool saved_in_omp_workshare;
1168
1169           /* There might be statement insertions before the current code,
1170              which must not affect the expression walker.  */
1171
1172           co = *c;
1173           saved_in_omp_workshare = in_omp_workshare;
1174
1175           switch (co->op)
1176             {
1177
1178             case EXEC_BLOCK:
1179               WALK_SUBCODE (co->ext.block.ns->code);
1180               for (alist = co->ext.block.assoc; alist; alist = alist->next)
1181                 WALK_SUBEXPR (alist->target);
1182               break;
1183
1184             case EXEC_DO:
1185               WALK_SUBEXPR (co->ext.iterator->var);
1186               WALK_SUBEXPR (co->ext.iterator->start);
1187               WALK_SUBEXPR (co->ext.iterator->end);
1188               WALK_SUBEXPR (co->ext.iterator->step);
1189               break;
1190
1191             case EXEC_CALL:
1192             case EXEC_ASSIGN_CALL:
1193               for (a = co->ext.actual; a; a = a->next)
1194                 WALK_SUBEXPR (a->expr);
1195               break;
1196
1197             case EXEC_CALL_PPC:
1198               WALK_SUBEXPR (co->expr1);
1199               for (a = co->ext.actual; a; a = a->next)
1200                 WALK_SUBEXPR (a->expr);
1201               break;
1202
1203             case EXEC_SELECT:
1204               WALK_SUBEXPR (co->expr1);
1205               for (b = co->block; b; b = b->block)
1206                 {
1207                   gfc_case *cp;
1208                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
1209                     {
1210                       WALK_SUBEXPR (cp->low);
1211                       WALK_SUBEXPR (cp->high);
1212                     }
1213                   WALK_SUBCODE (b->next);
1214                 }
1215               continue;
1216
1217             case EXEC_ALLOCATE:
1218             case EXEC_DEALLOCATE:
1219               {
1220                 gfc_alloc *a;
1221                 for (a = co->ext.alloc.list; a; a = a->next)
1222                   WALK_SUBEXPR (a->expr);
1223                 break;
1224               }
1225
1226             case EXEC_FORALL:
1227             case EXEC_DO_CONCURRENT:
1228               {
1229                 gfc_forall_iterator *fa;
1230                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
1231                   {
1232                     WALK_SUBEXPR (fa->var);
1233                     WALK_SUBEXPR (fa->start);
1234                     WALK_SUBEXPR (fa->end);
1235                     WALK_SUBEXPR (fa->stride);
1236                   }
1237                 if (co->op == EXEC_FORALL)
1238                   forall_level ++;
1239                 break;
1240               }
1241
1242             case EXEC_OPEN:
1243               WALK_SUBEXPR (co->ext.open->unit);
1244               WALK_SUBEXPR (co->ext.open->file);
1245               WALK_SUBEXPR (co->ext.open->status);
1246               WALK_SUBEXPR (co->ext.open->access);
1247               WALK_SUBEXPR (co->ext.open->form);
1248               WALK_SUBEXPR (co->ext.open->recl);
1249               WALK_SUBEXPR (co->ext.open->blank);
1250               WALK_SUBEXPR (co->ext.open->position);
1251               WALK_SUBEXPR (co->ext.open->action);
1252               WALK_SUBEXPR (co->ext.open->delim);
1253               WALK_SUBEXPR (co->ext.open->pad);
1254               WALK_SUBEXPR (co->ext.open->iostat);
1255               WALK_SUBEXPR (co->ext.open->iomsg);
1256               WALK_SUBEXPR (co->ext.open->convert);
1257               WALK_SUBEXPR (co->ext.open->decimal);
1258               WALK_SUBEXPR (co->ext.open->encoding);
1259               WALK_SUBEXPR (co->ext.open->round);
1260               WALK_SUBEXPR (co->ext.open->sign);
1261               WALK_SUBEXPR (co->ext.open->asynchronous);
1262               WALK_SUBEXPR (co->ext.open->id);
1263               WALK_SUBEXPR (co->ext.open->newunit);
1264               break;
1265
1266             case EXEC_CLOSE:
1267               WALK_SUBEXPR (co->ext.close->unit);
1268               WALK_SUBEXPR (co->ext.close->status);
1269               WALK_SUBEXPR (co->ext.close->iostat);
1270               WALK_SUBEXPR (co->ext.close->iomsg);
1271               break;
1272
1273             case EXEC_BACKSPACE:
1274             case EXEC_ENDFILE:
1275             case EXEC_REWIND:
1276             case EXEC_FLUSH:
1277               WALK_SUBEXPR (co->ext.filepos->unit);
1278               WALK_SUBEXPR (co->ext.filepos->iostat);
1279               WALK_SUBEXPR (co->ext.filepos->iomsg);
1280               break;
1281
1282             case EXEC_INQUIRE:
1283               WALK_SUBEXPR (co->ext.inquire->unit);
1284               WALK_SUBEXPR (co->ext.inquire->file);
1285               WALK_SUBEXPR (co->ext.inquire->iomsg);
1286               WALK_SUBEXPR (co->ext.inquire->iostat);
1287               WALK_SUBEXPR (co->ext.inquire->exist);
1288               WALK_SUBEXPR (co->ext.inquire->opened);
1289               WALK_SUBEXPR (co->ext.inquire->number);
1290               WALK_SUBEXPR (co->ext.inquire->named);
1291               WALK_SUBEXPR (co->ext.inquire->name);
1292               WALK_SUBEXPR (co->ext.inquire->access);
1293               WALK_SUBEXPR (co->ext.inquire->sequential);
1294               WALK_SUBEXPR (co->ext.inquire->direct);
1295               WALK_SUBEXPR (co->ext.inquire->form);
1296               WALK_SUBEXPR (co->ext.inquire->formatted);
1297               WALK_SUBEXPR (co->ext.inquire->unformatted);
1298               WALK_SUBEXPR (co->ext.inquire->recl);
1299               WALK_SUBEXPR (co->ext.inquire->nextrec);
1300               WALK_SUBEXPR (co->ext.inquire->blank);
1301               WALK_SUBEXPR (co->ext.inquire->position);
1302               WALK_SUBEXPR (co->ext.inquire->action);
1303               WALK_SUBEXPR (co->ext.inquire->read);
1304               WALK_SUBEXPR (co->ext.inquire->write);
1305               WALK_SUBEXPR (co->ext.inquire->readwrite);
1306               WALK_SUBEXPR (co->ext.inquire->delim);
1307               WALK_SUBEXPR (co->ext.inquire->encoding);
1308               WALK_SUBEXPR (co->ext.inquire->pad);
1309               WALK_SUBEXPR (co->ext.inquire->iolength);
1310               WALK_SUBEXPR (co->ext.inquire->convert);
1311               WALK_SUBEXPR (co->ext.inquire->strm_pos);
1312               WALK_SUBEXPR (co->ext.inquire->asynchronous);
1313               WALK_SUBEXPR (co->ext.inquire->decimal);
1314               WALK_SUBEXPR (co->ext.inquire->pending);
1315               WALK_SUBEXPR (co->ext.inquire->id);
1316               WALK_SUBEXPR (co->ext.inquire->sign);
1317               WALK_SUBEXPR (co->ext.inquire->size);
1318               WALK_SUBEXPR (co->ext.inquire->round);
1319               break;
1320
1321             case EXEC_WAIT:
1322               WALK_SUBEXPR (co->ext.wait->unit);
1323               WALK_SUBEXPR (co->ext.wait->iostat);
1324               WALK_SUBEXPR (co->ext.wait->iomsg);
1325               WALK_SUBEXPR (co->ext.wait->id);
1326               break;
1327
1328             case EXEC_READ:
1329             case EXEC_WRITE:
1330               WALK_SUBEXPR (co->ext.dt->io_unit);
1331               WALK_SUBEXPR (co->ext.dt->format_expr);
1332               WALK_SUBEXPR (co->ext.dt->rec);
1333               WALK_SUBEXPR (co->ext.dt->advance);
1334               WALK_SUBEXPR (co->ext.dt->iostat);
1335               WALK_SUBEXPR (co->ext.dt->size);
1336               WALK_SUBEXPR (co->ext.dt->iomsg);
1337               WALK_SUBEXPR (co->ext.dt->id);
1338               WALK_SUBEXPR (co->ext.dt->pos);
1339               WALK_SUBEXPR (co->ext.dt->asynchronous);
1340               WALK_SUBEXPR (co->ext.dt->blank);
1341               WALK_SUBEXPR (co->ext.dt->decimal);
1342               WALK_SUBEXPR (co->ext.dt->delim);
1343               WALK_SUBEXPR (co->ext.dt->pad);
1344               WALK_SUBEXPR (co->ext.dt->round);
1345               WALK_SUBEXPR (co->ext.dt->sign);
1346               WALK_SUBEXPR (co->ext.dt->extra_comma);
1347               break;
1348
1349             case EXEC_OMP_PARALLEL:
1350             case EXEC_OMP_PARALLEL_DO:
1351             case EXEC_OMP_PARALLEL_SECTIONS:
1352
1353               in_omp_workshare = false;
1354
1355               /* This goto serves as a shortcut to avoid code
1356                  duplication or a larger if or switch statement.  */
1357               goto check_omp_clauses;
1358
1359             case EXEC_OMP_WORKSHARE:
1360             case EXEC_OMP_PARALLEL_WORKSHARE:
1361
1362               in_omp_workshare = true;
1363
1364               /* Fall through  */
1365
1366             case EXEC_OMP_DO:
1367             case EXEC_OMP_SECTIONS:
1368             case EXEC_OMP_SINGLE:
1369             case EXEC_OMP_END_SINGLE:
1370             case EXEC_OMP_TASK:
1371
1372               /* Come to this label only from the
1373                  EXEC_OMP_PARALLEL_* cases above.  */
1374
1375             check_omp_clauses:
1376
1377               if (co->ext.omp_clauses)
1378                 {
1379                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
1380                   WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
1381                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
1382                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
1383                 }
1384               break;
1385             default:
1386               break;
1387             }
1388
1389           WALK_SUBEXPR (co->expr1);
1390           WALK_SUBEXPR (co->expr2);
1391           WALK_SUBEXPR (co->expr3);
1392           WALK_SUBEXPR (co->expr4);
1393           for (b = co->block; b; b = b->block)
1394             {
1395               WALK_SUBEXPR (b->expr1);
1396               WALK_SUBEXPR (b->expr2);
1397               WALK_SUBCODE (b->next);
1398             }
1399
1400           if (co->op == EXEC_FORALL)
1401             forall_level --;
1402
1403           in_omp_workshare = saved_in_omp_workshare;
1404         }
1405     }
1406   return 0;
1407 }