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