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