gcc/fortran/frontend-passes.c

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