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