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 /* Optimizations for an assignment.  */
 490
 491 static void
 492 optimize_assignment (gfc_code * c)
 493 {
 494   gfc_expr *lhs, *rhs;
 495
 496   lhs = c->expr1;
 497   rhs = c->expr2;
 498
 499   /* Optimize away a = trim(b), where a is a character variable.  */
 500
 501   if (lhs->ts.type == BT_CHARACTER)
 502     {
 503       /* Check for a // b // trim(c).  Looping is probably not
 504          necessary because the parser usually generates
 505          (// (// a b ) trim(c) ) , but better safe than sorry.  */
 506
 507       while (rhs->expr_type == EXPR_OP
 508              && rhs->value.op.op == INTRINSIC_CONCAT)
 509         rhs = rhs->value.op.op2;
 510
 511       if (rhs->expr_type == EXPR_FUNCTION &&
 512           rhs->value.function.isym &&
 513           rhs->value.function.isym->id == GFC_ISYM_TRIM)
 514         {
 515           strip_function_call (rhs);
 516           optimize_assignment (c);
 517           return;
 518         }
 519     }
 520
 521   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 522     optimize_binop_array_assignment (c, &rhs, false);
 523 }
 524
 525
 526 /* Remove an unneeded function call, modifying the expression.
 527    This replaces the function call with the value of its
 528    first argument.  The rest of the argument list is freed.  */
 529
 530 static void
 531 strip_function_call (gfc_expr *e)
 532 {
 533   gfc_expr *e1;
 534   gfc_actual_arglist *a;
 535
 536   a = e->value.function.actual;
 537
 538   /* We should have at least one argument.  */
 539   gcc_assert (a->expr != NULL);
 540
 541   e1 = a->expr;
 542
 543   /* Free the remaining arglist, if any.  */
 544   if (a->next)
 545     gfc_free_actual_arglist (a->next);
 546
 547   /* Graft the argument expression onto the original function.  */
 548   *e = *e1;
 549   free (e1);
 550
 551 }
 552
 553 /* Optimization of lexical comparison functions.  */
 554
 555 static bool
 556 optimize_lexical_comparison (gfc_expr *e)
 557 {
 558   if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
 559     return false;
 560
 561   switch (e->value.function.isym->id)
 562     {
 563     case GFC_ISYM_LLE:
 564       return optimize_comparison (e, INTRINSIC_LE);
 565
 566     case GFC_ISYM_LGE:
 567       return optimize_comparison (e, INTRINSIC_GE);
 568
 569     case GFC_ISYM_LGT:
 570       return optimize_comparison (e, INTRINSIC_GT);
 571
 572     case GFC_ISYM_LLT:
 573       return optimize_comparison (e, INTRINSIC_LT);
 574
 575     default:
 576       break;
 577     }
 578   return false;
 579 }
 580
 581 /* Recursive optimization of operators.  */
 582
 583 static bool
 584 optimize_op (gfc_expr *e)
 585 {
 586   gfc_intrinsic_op op = e->value.op.op;
 587
 588   switch (op)
 589     {
 590     case INTRINSIC_EQ:
 591     case INTRINSIC_EQ_OS:
 592     case INTRINSIC_GE:
 593     case INTRINSIC_GE_OS:
 594     case INTRINSIC_LE:
 595     case INTRINSIC_LE_OS:
 596     case INTRINSIC_NE:
 597     case INTRINSIC_NE_OS:
 598     case INTRINSIC_GT:
 599     case INTRINSIC_GT_OS:
 600     case INTRINSIC_LT:
 601     case INTRINSIC_LT_OS:
 602       return optimize_comparison (e, op);
 603
 604     default:
 605       break;
 606     }
 607
 608   return false;
 609 }
 610
 611 /* Optimize expressions for equality.  */
 612
 613 static bool
 614 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
 615 {
 616   gfc_expr *op1, *op2;
 617   bool change;
 618   int eq;
 619   bool result;
 620   gfc_actual_arglist *firstarg, *secondarg;
 621
 622   if (e->expr_type == EXPR_OP)
 623     {
 624       firstarg = NULL;
 625       secondarg = NULL;
 626       op1 = e->value.op.op1;
 627       op2 = e->value.op.op2;
 628     }
 629   else if (e->expr_type == EXPR_FUNCTION)
 630     {
 631       /* One of the lexical comparision functions.  */
 632       firstarg = e->value.function.actual;
 633       secondarg = firstarg->next;
 634       op1 = firstarg->expr;
 635       op2 = secondarg->expr;
 636     }
 637   else
 638     gcc_unreachable ();
 639
 640   /* Strip off unneeded TRIM calls from string comparisons.  */
 641
 642   change = false;
 643
 644   if (op1->expr_type == EXPR_FUNCTION
 645       && op1->value.function.isym
 646       && op1->value.function.isym->id == GFC_ISYM_TRIM)
 647     {
 648       strip_function_call (op1);
 649       change = true;
 650     }
 651
 652   if (op2->expr_type == EXPR_FUNCTION
 653       && op2->value.function.isym
 654       && op2->value.function.isym->id == GFC_ISYM_TRIM)
 655     {
 656       strip_function_call (op2);
 657       change = true;
 658     }
 659
 660   if (change)
 661     {
 662       optimize_comparison (e, op);
 663       return true;
 664     }
 665
 666   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 667   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 668      handles them well). However, there are also cases that need a non-scalar
 669      argument. For example the any intrinsic. See PR 45380.  */
 670   if (e->rank > 0)
 671     return false;
 672
 673   /* Don't compare REAL or COMPLEX expressions when honoring NaNs.  */
 674
 675   if (flag_finite_math_only
 676       || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 677           && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
 678     {
 679       eq = gfc_dep_compare_expr (op1, op2);
 680       if (eq == -2)
 681         {
 682           /* Replace A // B < A // C with B < C, and A // B < C // B
 683              with A < C.  */
 684           if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
 685               && op1->value.op.op == INTRINSIC_CONCAT
 686               && op2->value.op.op == INTRINSIC_CONCAT)
 687             {
 688               gfc_expr *op1_left = op1->value.op.op1;
 689               gfc_expr *op2_left = op2->value.op.op1;
 690               gfc_expr *op1_right = op1->value.op.op2;
 691               gfc_expr *op2_right = op2->value.op.op2;
 692
 693               if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
 694                 {
 695                   /* Watch out for 'A ' // x vs. 'A' // x.  */
 696
 697                   if (op1_left->expr_type == EXPR_CONSTANT
 698                         && op2_left->expr_type == EXPR_CONSTANT
 699                         && op1_left->value.character.length
 700                            != op2_left->value.character.length)
 701                     return false;
 702                   else
 703                     {
 704                       free (op1_left);
 705                       free (op2_left);
 706                       if (firstarg)
 707                         {
 708                           firstarg->expr = op1_right;
 709                           secondarg->expr = op2_right;
 710                         }
 711                       else
 712                         {
 713                           e->value.op.op1 = op1_right;
 714                           e->value.op.op2 = op2_right;
 715                         }
 716                       optimize_comparison (e, op);
 717                       return true;
 718                     }
 719                 }
 720               if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
 721                 {
 722                   free (op1_right);
 723                   free (op2_right);
 724                   if (firstarg)
 725                     {
 726                       firstarg->expr = op1_left;
 727                       secondarg->expr = op2_left;
 728                     }
 729                   else
 730                     {
 731                       e->value.op.op1 = op1_left;
 732                       e->value.op.op2 = op2_left;
 733                     }
 734
 735                   optimize_comparison (e, op);
 736                   return true;
 737                 }
 738             }
 739         }
 740       else
 741         {
 742           /* eq can only be -1, 0 or 1 at this point.  */
 743           switch (op)
 744             {
 745             case INTRINSIC_EQ:
 746             case INTRINSIC_EQ_OS:
 747               result = eq == 0;
 748               break;
 749
 750             case INTRINSIC_GE:
 751             case INTRINSIC_GE_OS:
 752               result = eq >= 0;
 753               break;
 754
 755             case INTRINSIC_LE:
 756             case INTRINSIC_LE_OS:
 757               result = eq <= 0;
 758               break;
 759
 760             case INTRINSIC_NE:
 761             case INTRINSIC_NE_OS:
 762               result = eq != 0;
 763               break;
 764
 765             case INTRINSIC_GT:
 766             case INTRINSIC_GT_OS:
 767               result = eq > 0;
 768               break;
 769
 770             case INTRINSIC_LT:
 771             case INTRINSIC_LT_OS:
 772               result = eq < 0;
 773               break;
 774
 775             default:
 776               gfc_internal_error ("illegal OP in optimize_comparison");
 777               break;
 778             }
 779
 780           /* Replace the expression by a constant expression.  The typespec
 781              and where remains the way it is.  */
 782           free (op1);
 783           free (op2);
 784           e->expr_type = EXPR_CONSTANT;
 785           e->value.logical = result;
 786           return true;
 787         }
 788     }
 789
 790   return false;
 791 }
 792
 793 /* Optimize a trim function by replacing it with an equivalent substring
 794    involving a call to len_trim.  This only works for expressions where
 795    variables are trimmed.  Return true if anything was modified.  */
 796
 797 static bool
 798 optimize_trim (gfc_expr *e)
 799 {
 800   gfc_expr *a;
 801   gfc_ref *ref;
 802   gfc_expr *fcn;
 803   gfc_actual_arglist *actual_arglist, *next;
 804   gfc_ref **rr = NULL;
 805
 806   /* Don't do this optimization within an argument list, because
 807      otherwise aliasing issues may occur.  */
 808
 809   if (count_arglist != 1)
 810     return false;
 811
 812   if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
 813       || e->value.function.isym == NULL
 814       || e->value.function.isym->id != GFC_ISYM_TRIM)
 815     return false;
 816
 817   a = e->value.function.actual->expr;
 818
 819   if (a->expr_type != EXPR_VARIABLE)
 820     return false;
 821
 822   /* Follow all references to find the correct place to put the newly
 823      created reference.  FIXME:  Also handle substring references and
 824      array references.  Array references cause strange regressions at
 825      the moment.  */
 826
 827   if (a->ref)
 828     {
 829       for (rr = &(a->ref); *rr; rr = &((*rr)->next))
 830         {
 831           if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
 832             return false;
 833         }
 834     }
 835
 836   strip_function_call (e);
 837
 838   if (e->ref == NULL)
 839     rr = &(e->ref);
 840
 841   /* Create the reference.  */
 842
 843   ref = gfc_get_ref ();
 844   ref->type = REF_SUBSTRING;
 845
 846   /* Set the start of the reference.  */
 847
 848   ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 849
 850   /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 851
 852   fcn = gfc_get_expr ();
 853   fcn->expr_type = EXPR_FUNCTION;
 854   fcn->value.function.isym =
 855     gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
 856   actual_arglist = gfc_get_actual_arglist ();
 857   actual_arglist->expr = gfc_copy_expr (e);
 858   next = gfc_get_actual_arglist ();
 859   next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
 860                                  gfc_default_integer_kind);
 861   actual_arglist->next = next;
 862   fcn->value.function.actual = actual_arglist;
 863
 864   /* Set the end of the reference to the call to len_trim.  */
 865
 866   ref->u.ss.end = fcn;
 867   gcc_assert (*rr == NULL);
 868   *rr = ref;
 869   return true;
 870 }
 871
 872 #define WALK_SUBEXPR(NODE) \
 873   do                                                    \
 874     {                                                   \
 875       result = gfc_expr_walker (&(NODE), exprfn, data); \
 876       if (result)                                       \
 877         return result;                                  \
 878     }                                                   \
 879   while (0)
 880 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
 881
 882 /* Walk expression *E, calling EXPRFN on each expression in it.  */
 883
 884 int
 885 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
 886 {
 887   while (*e)
 888     {
 889       int walk_subtrees = 1;
 890       gfc_actual_arglist *a;
 891       gfc_ref *r;
 892       gfc_constructor *c;
 893
 894       int result = exprfn (e, &walk_subtrees, data);
 895       if (result)
 896         return result;
 897       if (walk_subtrees)
 898         switch ((*e)->expr_type)
 899           {
 900           case EXPR_OP:
 901             WALK_SUBEXPR ((*e)->value.op.op1);
 902             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
 903             break;
 904           case EXPR_FUNCTION:
 905             for (a = (*e)->value.function.actual; a; a = a->next)
 906               WALK_SUBEXPR (a->expr);
 907             break;
 908           case EXPR_COMPCALL:
 909           case EXPR_PPC:
 910             WALK_SUBEXPR ((*e)->value.compcall.base_object);
 911             for (a = (*e)->value.compcall.actual; a; a = a->next)
 912               WALK_SUBEXPR (a->expr);
 913             break;
 914
 915           case EXPR_STRUCTURE:
 916           case EXPR_ARRAY:
 917             for (c = gfc_constructor_first ((*e)->value.constructor); c;
 918                  c = gfc_constructor_next (c))
 919               {
 920                 WALK_SUBEXPR (c->expr);
 921                 if (c->iterator != NULL)
 922                   {
 923                     WALK_SUBEXPR (c->iterator->var);
 924                     WALK_SUBEXPR (c->iterator->start);
 925                     WALK_SUBEXPR (c->iterator->end);
 926                     WALK_SUBEXPR (c->iterator->step);
 927                   }
 928               }
 929
 930             if ((*e)->expr_type != EXPR_ARRAY)
 931               break;
 932
 933             /* Fall through to the variable case in order to walk the
 934                reference.  */
 935
 936           case EXPR_SUBSTRING:
 937           case EXPR_VARIABLE:
 938             for (r = (*e)->ref; r; r = r->next)
 939               {
 940                 gfc_array_ref *ar;
 941                 int i;
 942
 943                 switch (r->type)
 944                   {
 945                   case REF_ARRAY:
 946                     ar = &r->u.ar;
 947                     if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
 948                       {
 949                         for (i=0; i< ar->dimen; i++)
 950                           {
 951                             WALK_SUBEXPR (ar->start[i]);
 952                             WALK_SUBEXPR (ar->end[i]);
 953                             WALK_SUBEXPR (ar->stride[i]);
 954                           }
 955                       }
 956
 957                     break;
 958
 959                   case REF_SUBSTRING:
 960                     WALK_SUBEXPR (r->u.ss.start);
 961                     WALK_SUBEXPR (r->u.ss.end);
 962                     break;
 963
 964                   case REF_COMPONENT:
 965                     break;
 966                   }
 967               }
 968
 969           default:
 970             break;
 971           }
 972       return 0;
 973     }
 974   return 0;
 975 }
 976
 977 #define WALK_SUBCODE(NODE) \
 978   do                                                            \
 979     {                                                           \
 980       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
 981       if (result)                                               \
 982         return result;                                          \
 983     }                                                           \
 984   while (0)
 985
 986 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
 987    on each expression in it.  If any of the hooks returns non-zero, that
 988    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
 989    no subcodes or subexpressions are traversed.  */
 990
 991 int
 992 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 993                  void *data)
 994 {
 995   for (; *c; c = &(*c)->next)
 996     {
 997       int walk_subtrees = 1;
 998       int result = codefn (c, &walk_subtrees, data);
 999       if (result)
1000         return result;
1001
1002       if (walk_subtrees)
1003         {
1004           gfc_code *b;
1005           gfc_actual_arglist *a;
1006           gfc_code *co;
1007
1008           /* There might be statement insertions before the current code,
1009              which must not affect the expression walker.  */
1010
1011           co = *c;
1012
1013           switch (co->op)
1014             {
1015             case EXEC_DO:
1016               WALK_SUBEXPR (co->ext.iterator->var);
1017               WALK_SUBEXPR (co->ext.iterator->start);
1018               WALK_SUBEXPR (co->ext.iterator->end);
1019               WALK_SUBEXPR (co->ext.iterator->step);
1020               break;
1021
1022             case EXEC_CALL:
1023             case EXEC_ASSIGN_CALL:
1024               for (a = co->ext.actual; a; a = a->next)
1025                 WALK_SUBEXPR (a->expr);
1026               break;
1027
1028             case EXEC_CALL_PPC:
1029               WALK_SUBEXPR (co->expr1);
1030               for (a = co->ext.actual; a; a = a->next)
1031                 WALK_SUBEXPR (a->expr);
1032               break;
1033
1034             case EXEC_SELECT:
1035               WALK_SUBEXPR (co->expr1);
1036               for (b = co->block; b; b = b->block)
1037                 {
1038                   gfc_case *cp;
1039                   for (cp = b->ext.block.case_list; cp; cp = cp->next)
1040                     {
1041                       WALK_SUBEXPR (cp->low);
1042                       WALK_SUBEXPR (cp->high);
1043                     }
1044                   WALK_SUBCODE (b->next);
1045                 }
1046               continue;
1047
1048             case EXEC_ALLOCATE:
1049             case EXEC_DEALLOCATE:
1050               {
1051                 gfc_alloc *a;
1052                 for (a = co->ext.alloc.list; a; a = a->next)
1053                   WALK_SUBEXPR (a->expr);
1054                 break;
1055               }
1056
1057             case EXEC_FORALL:
1058               {
1059                 gfc_forall_iterator *fa;
1060                 for (fa = co->ext.forall_iterator; fa; fa = fa->next)
1061                   {
1062                     WALK_SUBEXPR (fa->var);
1063                     WALK_SUBEXPR (fa->start);
1064                     WALK_SUBEXPR (fa->end);
1065                     WALK_SUBEXPR (fa->stride);
1066                   }
1067                 break;
1068               }
1069
1070             case EXEC_OPEN:
1071               WALK_SUBEXPR (co->ext.open->unit);
1072               WALK_SUBEXPR (co->ext.open->file);
1073               WALK_SUBEXPR (co->ext.open->status);
1074               WALK_SUBEXPR (co->ext.open->access);
1075               WALK_SUBEXPR (co->ext.open->form);
1076               WALK_SUBEXPR (co->ext.open->recl);
1077               WALK_SUBEXPR (co->ext.open->blank);
1078               WALK_SUBEXPR (co->ext.open->position);
1079               WALK_SUBEXPR (co->ext.open->action);
1080               WALK_SUBEXPR (co->ext.open->delim);
1081               WALK_SUBEXPR (co->ext.open->pad);
1082               WALK_SUBEXPR (co->ext.open->iostat);
1083               WALK_SUBEXPR (co->ext.open->iomsg);
1084               WALK_SUBEXPR (co->ext.open->convert);
1085               WALK_SUBEXPR (co->ext.open->decimal);
1086               WALK_SUBEXPR (co->ext.open->encoding);
1087               WALK_SUBEXPR (co->ext.open->round);
1088               WALK_SUBEXPR (co->ext.open->sign);
1089               WALK_SUBEXPR (co->ext.open->asynchronous);
1090               WALK_SUBEXPR (co->ext.open->id);
1091               WALK_SUBEXPR (co->ext.open->newunit);
1092               break;
1093
1094             case EXEC_CLOSE:
1095               WALK_SUBEXPR (co->ext.close->unit);
1096               WALK_SUBEXPR (co->ext.close->status);
1097               WALK_SUBEXPR (co->ext.close->iostat);
1098               WALK_SUBEXPR (co->ext.close->iomsg);
1099               break;
1100
1101             case EXEC_BACKSPACE:
1102             case EXEC_ENDFILE:
1103             case EXEC_REWIND:
1104             case EXEC_FLUSH:
1105               WALK_SUBEXPR (co->ext.filepos->unit);
1106               WALK_SUBEXPR (co->ext.filepos->iostat);
1107               WALK_SUBEXPR (co->ext.filepos->iomsg);
1108               break;
1109
1110             case EXEC_INQUIRE:
1111               WALK_SUBEXPR (co->ext.inquire->unit);
1112               WALK_SUBEXPR (co->ext.inquire->file);
1113               WALK_SUBEXPR (co->ext.inquire->iomsg);
1114               WALK_SUBEXPR (co->ext.inquire->iostat);
1115               WALK_SUBEXPR (co->ext.inquire->exist);
1116               WALK_SUBEXPR (co->ext.inquire->opened);
1117               WALK_SUBEXPR (co->ext.inquire->number);
1118               WALK_SUBEXPR (co->ext.inquire->named);
1119               WALK_SUBEXPR (co->ext.inquire->name);
1120               WALK_SUBEXPR (co->ext.inquire->access);
1121               WALK_SUBEXPR (co->ext.inquire->sequential);
1122               WALK_SUBEXPR (co->ext.inquire->direct);
1123               WALK_SUBEXPR (co->ext.inquire->form);
1124               WALK_SUBEXPR (co->ext.inquire->formatted);
1125               WALK_SUBEXPR (co->ext.inquire->unformatted);
1126               WALK_SUBEXPR (co->ext.inquire->recl);
1127               WALK_SUBEXPR (co->ext.inquire->nextrec);
1128               WALK_SUBEXPR (co->ext.inquire->blank);
1129               WALK_SUBEXPR (co->ext.inquire->position);
1130               WALK_SUBEXPR (co->ext.inquire->action);
1131               WALK_SUBEXPR (co->ext.inquire->read);
1132               WALK_SUBEXPR (co->ext.inquire->write);
1133               WALK_SUBEXPR (co->ext.inquire->readwrite);
1134               WALK_SUBEXPR (co->ext.inquire->delim);
1135               WALK_SUBEXPR (co->ext.inquire->encoding);
1136               WALK_SUBEXPR (co->ext.inquire->pad);
1137               WALK_SUBEXPR (co->ext.inquire->iolength);
1138               WALK_SUBEXPR (co->ext.inquire->convert);
1139               WALK_SUBEXPR (co->ext.inquire->strm_pos);
1140               WALK_SUBEXPR (co->ext.inquire->asynchronous);
1141               WALK_SUBEXPR (co->ext.inquire->decimal);
1142               WALK_SUBEXPR (co->ext.inquire->pending);
1143               WALK_SUBEXPR (co->ext.inquire->id);
1144               WALK_SUBEXPR (co->ext.inquire->sign);
1145               WALK_SUBEXPR (co->ext.inquire->size);
1146               WALK_SUBEXPR (co->ext.inquire->round);
1147               break;
1148
1149             case EXEC_WAIT:
1150               WALK_SUBEXPR (co->ext.wait->unit);
1151               WALK_SUBEXPR (co->ext.wait->iostat);
1152               WALK_SUBEXPR (co->ext.wait->iomsg);
1153               WALK_SUBEXPR (co->ext.wait->id);
1154               break;
1155
1156             case EXEC_READ:
1157             case EXEC_WRITE:
1158               WALK_SUBEXPR (co->ext.dt->io_unit);
1159               WALK_SUBEXPR (co->ext.dt->format_expr);
1160               WALK_SUBEXPR (co->ext.dt->rec);
1161               WALK_SUBEXPR (co->ext.dt->advance);
1162               WALK_SUBEXPR (co->ext.dt->iostat);
1163               WALK_SUBEXPR (co->ext.dt->size);
1164               WALK_SUBEXPR (co->ext.dt->iomsg);
1165               WALK_SUBEXPR (co->ext.dt->id);
1166               WALK_SUBEXPR (co->ext.dt->pos);
1167               WALK_SUBEXPR (co->ext.dt->asynchronous);
1168               WALK_SUBEXPR (co->ext.dt->blank);
1169               WALK_SUBEXPR (co->ext.dt->decimal);
1170               WALK_SUBEXPR (co->ext.dt->delim);
1171               WALK_SUBEXPR (co->ext.dt->pad);
1172               WALK_SUBEXPR (co->ext.dt->round);
1173               WALK_SUBEXPR (co->ext.dt->sign);
1174               WALK_SUBEXPR (co->ext.dt->extra_comma);
1175               break;
1176
1177             case EXEC_OMP_DO:
1178             case EXEC_OMP_PARALLEL:
1179             case EXEC_OMP_PARALLEL_DO:
1180             case EXEC_OMP_PARALLEL_SECTIONS:
1181             case EXEC_OMP_PARALLEL_WORKSHARE:
1182             case EXEC_OMP_SECTIONS:
1183             case EXEC_OMP_SINGLE:
1184             case EXEC_OMP_WORKSHARE:
1185             case EXEC_OMP_END_SINGLE:
1186             case EXEC_OMP_TASK:
1187               if (co->ext.omp_clauses)
1188                 {
1189                   WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
1190                   WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
1191                   WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
1192                 }
1193               break;
1194             default:
1195               break;
1196             }
1197
1198           WALK_SUBEXPR (co->expr1);
1199           WALK_SUBEXPR (co->expr2);
1200           WALK_SUBEXPR (co->expr3);
1201           WALK_SUBEXPR (co->expr4);
1202           for (b = co->block; b; b = b->block)
1203             {
1204               WALK_SUBEXPR (b->expr1);
1205               WALK_SUBEXPR (b->expr2);
1206               WALK_SUBCODE (b->next);
1207             }
1208         }
1209     }
1210   return 0;
1211 }