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
  27 /* Forward declarations.  */
  28
  29 static void strip_function_call (gfc_expr *);
  30 static void optimize_assignment (gfc_code *);
  31 static void optimize_expr_0 (gfc_expr *);
  32 static bool optimize_expr (gfc_expr *);
  33 static bool optimize_op (gfc_expr *);
  34 static bool optimize_equality (gfc_expr *, bool);
  35 static void optimize_code (gfc_code *);
  36 static void optimize_code_node (gfc_code *);
  37 static void optimize_actual_arglist (gfc_actual_arglist *);
  38
  39 /* Entry point - run all passes for a namespace.  So far, only an
  40    optimization pass is run.  */
  41
  42 void
  43 gfc_run_passes (gfc_namespace * ns)
  44 {
  45   if (optimize)
  46     optimize_code (ns->code);
  47 }
  48
  49 static void
  50 optimize_code (gfc_code *c)
  51 {
  52   for (; c; c = c->next)
  53     optimize_code_node (c);
  54 }
  55
  56
  57 /* Do the optimizations for a code node.  */
  58
  59 static void
  60 optimize_code_node (gfc_code *c)
  61 {
  62
  63   gfc_forall_iterator *fa;
  64   gfc_code *d;
  65   gfc_alloc *a;
  66
  67   switch (c->op)
  68     {
  69     case EXEC_ASSIGN:
  70       optimize_assignment (c);
  71       break;
  72
  73     case EXEC_CALL:
  74     case EXEC_ASSIGN_CALL:
  75     case EXEC_CALL_PPC:
  76       optimize_actual_arglist (c->ext.actual);
  77       break;
  78
  79     case EXEC_ARITHMETIC_IF:
  80       optimize_expr_0 (c->expr1);
  81       break;
  82
  83     case EXEC_PAUSE:
  84     case EXEC_RETURN:
  85     case EXEC_ERROR_STOP:
  86     case EXEC_STOP:
  87     case EXEC_COMPCALL:
  88       optimize_expr_0 (c->expr1);
  89       break;
  90
  91     case EXEC_SYNC_ALL:
  92     case EXEC_SYNC_MEMORY:
  93     case EXEC_SYNC_IMAGES:
  94       optimize_expr_0 (c->expr2);
  95       break;
  96
  97     case EXEC_IF:
  98       d = c->block;
  99       optimize_expr_0 (d->expr1);
 100       optimize_code (d->next);
 101
 102       for (d = d->block; d; d = d->block)
 103         {
 104           optimize_expr_0 (d->expr1);
 105
 106           optimize_code (d->next);
 107         }
 108
 109
 110       break;
 111
 112     case EXEC_SELECT:
 113     case EXEC_SELECT_TYPE:
 114       d = c->block;
 115
 116       optimize_expr_0 (c->expr1);
 117
 118       for (; d; d = d->block)
 119         optimize_code (d->next);
 120
 121       break;
 122
 123     case EXEC_WHERE:
 124       d = c->block;
 125       optimize_expr_0 (d->expr1);
 126       optimize_code (d->next);
 127
 128       for (d = d->block; d; d = d->block)
 129         {
 130           optimize_expr_0 (d->expr1);
 131           optimize_code (d->next);
 132         }
 133       break;
 134
 135     case EXEC_FORALL:
 136
 137       for (fa = c->ext.forall_iterator; fa; fa = fa->next)
 138         {
 139           optimize_expr_0 (fa->start);
 140           optimize_expr_0 (fa->end);
 141           optimize_expr_0 (fa->stride);
 142         }
 143
 144       if (c->expr1 != NULL)
 145           optimize_expr_0 (c->expr1);
 146
 147       optimize_code (c->block->next);
 148
 149       break;
 150
 151     case EXEC_CRITICAL:
 152       optimize_code (c->block->next);
 153       break;
 154
 155     case EXEC_DO:
 156       optimize_expr_0 (c->ext.iterator->start);
 157       optimize_expr_0 (c->ext.iterator->end);
 158       optimize_expr_0 (c->ext.iterator->step);
 159       optimize_code (c->block->next);
 160
 161       break;
 162
 163     case EXEC_DO_WHILE:
 164       optimize_expr_0 (c->expr1);
 165       optimize_code (c->block->next);
 166       break;
 167
 168
 169     case EXEC_ALLOCATE:
 170       for (a = c->ext.alloc.list; a; a = a->next)
 171           optimize_expr_0 (a->expr);
 172       break;
 173
 174       /* Todo:  Some of these may need to be optimized, as well.  */
 175     case EXEC_WRITE:
 176     case EXEC_READ:
 177     case EXEC_OPEN:
 178     case EXEC_INQUIRE:
 179     case EXEC_REWIND:
 180     case EXEC_ENDFILE:
 181     case EXEC_BACKSPACE:
 182     case EXEC_CLOSE:
 183     case EXEC_WAIT:
 184     case EXEC_TRANSFER:
 185     case EXEC_FLUSH:
 186     case EXEC_IOLENGTH:
 187     case EXEC_END_PROCEDURE:
 188     case EXEC_NOP:
 189     case EXEC_CONTINUE:
 190     case EXEC_ENTRY:
 191     case EXEC_INIT_ASSIGN:
 192     case EXEC_LABEL_ASSIGN:
 193     case EXEC_POINTER_ASSIGN:
 194     case EXEC_GOTO:
 195     case EXEC_CYCLE:
 196     case EXEC_EXIT:
 197     case EXEC_BLOCK:
 198     case EXEC_END_BLOCK:
 199     case EXEC_OMP_ATOMIC:
 200     case EXEC_OMP_BARRIER:
 201     case EXEC_OMP_CRITICAL:
 202     case EXEC_OMP_FLUSH:
 203     case EXEC_OMP_DO:
 204     case EXEC_OMP_MASTER:
 205     case EXEC_OMP_ORDERED:
 206     case EXEC_OMP_PARALLEL:
 207     case EXEC_OMP_PARALLEL_DO:
 208     case EXEC_OMP_PARALLEL_SECTIONS:
 209     case EXEC_OMP_PARALLEL_WORKSHARE:
 210     case EXEC_OMP_SECTIONS:
 211     case EXEC_OMP_SINGLE:
 212     case EXEC_OMP_TASK:
 213     case EXEC_OMP_TASKWAIT:
 214     case EXEC_OMP_WORKSHARE:
 215     case EXEC_DEALLOCATE:
 216
 217       break;
 218
 219     default:
 220       gcc_unreachable ();
 221
 222     }
 223 }
 224
 225 /* Optimizations for an assignment.  */
 226
 227 static void
 228 optimize_assignment (gfc_code * c)
 229 {
 230   gfc_expr *lhs, *rhs;
 231
 232   lhs = c->expr1;
 233   rhs = c->expr2;
 234
 235   /* Optimize away a = trim(b), where a is a character variable.  */
 236
 237   if (lhs->ts.type == BT_CHARACTER)
 238     {
 239       if (rhs->expr_type == EXPR_FUNCTION &&
 240           rhs->value.function.isym &&
 241           rhs->value.function.isym->id == GFC_ISYM_TRIM)
 242         {
 243           strip_function_call (rhs);
 244           optimize_assignment (c);
 245           return;
 246         }
 247     }
 248
 249   /* All direct optimizations have been done.  Now it's time
 250      to optimize the rhs.  */
 251
 252   optimize_expr_0 (rhs);
 253 }
 254
 255
 256 /* Remove an unneeded function call, modifying the expression.
 257    This replaces the function call with the value of its
 258    first argument.  The rest of the argument list is freed.  */
 259
 260 static void
 261 strip_function_call (gfc_expr *e)
 262 {
 263   gfc_expr *e1;
 264   gfc_actual_arglist *a;
 265
 266   a = e->value.function.actual;
 267
 268   /* We should have at least one argument.  */
 269   gcc_assert (a->expr != NULL);
 270
 271   e1 = a->expr;
 272
 273   /* Free the remaining arglist, if any.  */
 274   if (a->next)
 275     gfc_free_actual_arglist (a->next);
 276
 277   /* Graft the argument expression onto the original function.  */
 278   *e = *e1;
 279   gfc_free (e1);
 280
 281 }
 282
 283 /* Top-level optimization of expressions.  Calls gfc_simplify_expr if
 284    optimize_expr succeeds in doing something.
 285    TODO: Optimization of multiple function occurrence to come here.  */
 286
 287 static void
 288 optimize_expr_0 (gfc_expr * e)
 289 {
 290   if (optimize_expr (e))
 291     gfc_simplify_expr (e, 0);
 292
 293   return;
 294 }
 295
 296 /* Recursive optimization of expressions.
 297  TODO:  Make this handle many more things.  */
 298
 299 static bool
 300 optimize_expr (gfc_expr *e)
 301 {
 302   bool ret;
 303
 304   if (e == NULL)
 305     return false;
 306
 307   ret = false;
 308
 309   switch (e->expr_type)
 310     {
 311     case EXPR_OP:
 312       return optimize_op (e);
 313       break;
 314
 315     case EXPR_FUNCTION:
 316       optimize_actual_arglist (e->value.function.actual);
 317       break;
 318
 319     default:
 320       break;
 321     }
 322
 323   return ret;
 324 }
 325
 326 /* Recursive optimization of operators.  */
 327
 328 static bool
 329 optimize_op (gfc_expr *e)
 330 {
 331
 332   gfc_intrinsic_op op;
 333
 334   op = e->value.op.op;
 335
 336   switch (op)
 337     {
 338     case INTRINSIC_EQ:
 339     case INTRINSIC_EQ_OS:
 340     case INTRINSIC_GE:
 341     case INTRINSIC_GE_OS:
 342     case INTRINSIC_LE:
 343     case INTRINSIC_LE_OS:
 344       return optimize_equality (e, true);
 345       break;
 346
 347     case INTRINSIC_NE:
 348     case INTRINSIC_NE_OS:
 349     case INTRINSIC_GT:
 350     case INTRINSIC_GT_OS:
 351     case INTRINSIC_LT:
 352     case INTRINSIC_LT_OS:
 353       return optimize_equality (e, false);
 354       break;
 355
 356     default:
 357       break;
 358     }
 359
 360   return false;
 361 }
 362
 363 /* Optimize expressions for equality.  */
 364
 365 static bool
 366 optimize_equality (gfc_expr *e, bool equal)
 367 {
 368
 369   gfc_expr *op1, *op2;
 370   bool change;
 371
 372   op1 = e->value.op.op1;
 373   op2 = e->value.op.op2;
 374
 375   /* Strip off unneeded TRIM calls from string comparisons.  */
 376
 377   change = false;
 378
 379   if (op1->expr_type == EXPR_FUNCTION
 380       && op1->value.function.isym
 381       && op1->value.function.isym->id == GFC_ISYM_TRIM)
 382     {
 383       strip_function_call (op1);
 384       change = true;
 385     }
 386
 387   if (op2->expr_type == EXPR_FUNCTION
 388       && op2->value.function.isym
 389       && op2->value.function.isym->id == GFC_ISYM_TRIM)
 390     {
 391       strip_function_call (op2);
 392       change = true;
 393     }
 394
 395   if (change)
 396     {
 397       optimize_equality (e, equal);
 398       return true;
 399     }
 400
 401   /* Check for direct comparison between identical variables.
 402      TODO: Handle cases with identical refs.  */
 403   if (op1->expr_type == EXPR_VARIABLE
 404       && op2->expr_type == EXPR_VARIABLE
 405       && op1->symtree == op2->symtree
 406       && op1->ref == NULL && op2->ref == NULL
 407       && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 408       && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX)
 409     {
 410       /* Replace the expression by a constant expression.  The typespec
 411          and where remains the way it is.  */
 412       gfc_free (op1);
 413       gfc_free (op2);
 414       e->expr_type = EXPR_CONSTANT;
 415       e->value.logical = equal;
 416       return true;
 417     }
 418   return false;
 419 }
 420
 421 /* Optimize a call list.  Right now, this just goes through the actual
 422    arg list and optimizes each expression in turn.  */
 423
 424 static void
 425 optimize_actual_arglist (gfc_actual_arglist *a)
 426 {
 427
 428   for (; a; a = a->next)
 429     {
 430       if (a->expr != NULL)
 431         optimize_expr_0 (a->expr);
 432     }
 433
 434   return;
 435 }