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
  28 /* Forward declarations.  */
  29
  30 static void strip_function_call (gfc_expr *);
  31 static void optimize_namespace (gfc_namespace *);
  32 static void optimize_assignment (gfc_code *);
  33 static bool optimize_op (gfc_expr *);
  34 static bool optimize_equality (gfc_expr *, bool);
  35
  36 /* Entry point - run all passes for a namespace.  So far, only an
  37    optimization pass is run.  */
  38
  39 void
  40 gfc_run_passes (gfc_namespace *ns)
  41 {
  42   if (optimize)
  43     optimize_namespace (ns);
  44 }
  45
  46 /* Callback for each gfc_code node invoked through gfc_code_walker
  47    from optimize_namespace.  */
  48
  49 static int
  50 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
  51                void *data ATTRIBUTE_UNUSED)
  52 {
  53   if ((*c)->op == EXEC_ASSIGN)
  54     optimize_assignment (*c);
  55   return 0;
  56 }
  57
  58 /* Callback for each gfc_expr node invoked through gfc_code_walker
  59    from optimize_namespace.  */
  60
  61 static int
  62 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
  63                void *data ATTRIBUTE_UNUSED)
  64 {
  65   if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
  66     gfc_simplify_expr (*e, 0);
  67   return 0;
  68 }
  69
  70 /* Optimize a namespace, including all contained namespaces.  */
  71
  72 static void
  73 optimize_namespace (gfc_namespace *ns)
  74 {
  75   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
  76
  77   for (ns = ns->contained; ns; ns = ns->sibling)
  78     optimize_namespace (ns);
  79 }
  80
  81 /* Replace code like
  82    a = matmul(b,c) + d
  83    with
  84    a = matmul(b,c) ;   a = a + d
  85    where the array function is not elemental and not allocatable
  86    and does not depend on the left-hand side.
  87 */
  88
  89 static bool
  90 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
  91 {
  92   gfc_expr *e;
  93
  94   e = *rhs;
  95   if (e->expr_type == EXPR_OP)
  96     {
  97       switch (e->value.op.op)
  98         {
  99           /* Unary operators and exponentiation: Only look at a single
 100              operand.  */
 101         case INTRINSIC_NOT:
 102         case INTRINSIC_UPLUS:
 103         case INTRINSIC_UMINUS:
 104         case INTRINSIC_PARENTHESES:
 105         case INTRINSIC_POWER:
 106           if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
 107             return true;
 108           break;
 109
 110         default:
 111           /* Binary operators.  */
 112           if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
 113             return true;
 114
 115           if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
 116             return true;
 117
 118           break;
 119         }
 120     }
 121   else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
 122            && ! (e->value.function.esym
 123                  && (e->value.function.esym->attr.elemental
 124                      || e->value.function.esym->attr.allocatable))
 125            && ! (e->value.function.isym && e->value.function.isym->elemental))
 126     {
 127
 128       gfc_code *n;
 129       gfc_expr *new_expr;
 130
 131       /* Insert a new assignment statement after the current one.  */
 132       n = XCNEW (gfc_code);
 133       n->op = EXEC_ASSIGN;
 134       n->loc = c->loc;
 135       n->next = c->next;
 136       c->next = n;
 137
 138       n->expr1 = gfc_copy_expr (c->expr1);
 139       n->expr2 = c->expr2;
 140       new_expr = gfc_copy_expr (c->expr1);
 141       c->expr2 = e;
 142       *rhs = new_expr;
 143
 144       return true;
 145
 146     }
 147
 148   /* Nothing to optimize.  */
 149   return false;
 150 }
 151
 152 /* Optimizations for an assignment.  */
 153
 154 static void
 155 optimize_assignment (gfc_code * c)
 156 {
 157   gfc_expr *lhs, *rhs;
 158
 159   lhs = c->expr1;
 160   rhs = c->expr2;
 161
 162   /* Optimize away a = trim(b), where a is a character variable.  */
 163
 164   if (lhs->ts.type == BT_CHARACTER)
 165     {
 166       if (rhs->expr_type == EXPR_FUNCTION &&
 167           rhs->value.function.isym &&
 168           rhs->value.function.isym->id == GFC_ISYM_TRIM)
 169         {
 170           strip_function_call (rhs);
 171           optimize_assignment (c);
 172           return;
 173         }
 174     }
 175
 176   if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
 177     optimize_binop_array_assignment (c, &rhs, false);
 178 }
 179
 180
 181 /* Remove an unneeded function call, modifying the expression.
 182    This replaces the function call with the value of its
 183    first argument.  The rest of the argument list is freed.  */
 184
 185 static void
 186 strip_function_call (gfc_expr *e)
 187 {
 188   gfc_expr *e1;
 189   gfc_actual_arglist *a;
 190
 191   a = e->value.function.actual;
 192
 193   /* We should have at least one argument.  */
 194   gcc_assert (a->expr != NULL);
 195
 196   e1 = a->expr;
 197
 198   /* Free the remaining arglist, if any.  */
 199   if (a->next)
 200     gfc_free_actual_arglist (a->next);
 201
 202   /* Graft the argument expression onto the original function.  */
 203   *e = *e1;
 204   gfc_free (e1);
 205
 206 }
 207
 208 /* Recursive optimization of operators.  */
 209
 210 static bool
 211 optimize_op (gfc_expr *e)
 212 {
 213   gfc_intrinsic_op op = e->value.op.op;
 214
 215   switch (op)
 216     {
 217     case INTRINSIC_EQ:
 218     case INTRINSIC_EQ_OS:
 219     case INTRINSIC_GE:
 220     case INTRINSIC_GE_OS:
 221     case INTRINSIC_LE:
 222     case INTRINSIC_LE_OS:
 223       return optimize_equality (e, true);
 224
 225     case INTRINSIC_NE:
 226     case INTRINSIC_NE_OS:
 227     case INTRINSIC_GT:
 228     case INTRINSIC_GT_OS:
 229     case INTRINSIC_LT:
 230     case INTRINSIC_LT_OS:
 231       return optimize_equality (e, false);
 232
 233     default:
 234       break;
 235     }
 236
 237   return false;
 238 }
 239
 240 /* Optimize expressions for equality.  */
 241
 242 static bool
 243 optimize_equality (gfc_expr *e, bool equal)
 244 {
 245   gfc_expr *op1, *op2;
 246   bool change;
 247
 248   op1 = e->value.op.op1;
 249   op2 = e->value.op.op2;
 250
 251   /* Strip off unneeded TRIM calls from string comparisons.  */
 252
 253   change = false;
 254
 255   if (op1->expr_type == EXPR_FUNCTION
 256       && op1->value.function.isym
 257       && op1->value.function.isym->id == GFC_ISYM_TRIM)
 258     {
 259       strip_function_call (op1);
 260       change = true;
 261     }
 262
 263   if (op2->expr_type == EXPR_FUNCTION
 264       && op2->value.function.isym
 265       && op2->value.function.isym->id == GFC_ISYM_TRIM)
 266     {
 267       strip_function_call (op2);
 268       change = true;
 269     }
 270
 271   if (change)
 272     {
 273       optimize_equality (e, equal);
 274       return true;
 275     }
 276
 277   /* An expression of type EXPR_CONSTANT is only valid for scalars.  */
 278   /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
 279      handles them well). However, there are also cases that need a non-scalar
 280      argument. For example the any intrinsic. See PR 45380.  */
 281   if (e->rank > 0)
 282     return false;
 283
 284   /* Check for direct comparison between identical variables.  Don't compare
 285      REAL or COMPLEX because of NaN checks.  */
 286   if (op1->expr_type == EXPR_VARIABLE
 287       && op2->expr_type == EXPR_VARIABLE
 288       && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
 289       && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX
 290       && gfc_are_identical_variables (op1, op2))
 291     {
 292       /* Replace the expression by a constant expression.  The typespec
 293          and where remains the way it is.  */
 294       gfc_free (op1);
 295       gfc_free (op2);
 296       e->expr_type = EXPR_CONSTANT;
 297       e->value.logical = equal;
 298       return true;
 299     }
 300   return false;
 301 }
 302
 303 #define WALK_SUBEXPR(NODE) \
 304   do                                                    \
 305     {                                                   \
 306       result = gfc_expr_walker (&(NODE), exprfn, data); \
 307       if (result)                                       \
 308         return result;                                  \
 309     }                                                   \
 310   while (0)
 311 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
 312
 313 /* Walk expression *E, calling EXPRFN on each expression in it.  */
 314
 315 int
 316 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
 317 {
 318   while (*e)
 319     {
 320       int walk_subtrees = 1;
 321       gfc_actual_arglist *a;
 322       int result = exprfn (e, &walk_subtrees, data);
 323       if (result)
 324         return result;
 325       if (walk_subtrees)
 326         switch ((*e)->expr_type)
 327           {
 328           case EXPR_OP:
 329             WALK_SUBEXPR ((*e)->value.op.op1);
 330             WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
 331             break;
 332           case EXPR_FUNCTION:
 333             for (a = (*e)->value.function.actual; a; a = a->next)
 334               WALK_SUBEXPR (a->expr);
 335             break;
 336           case EXPR_COMPCALL:
 337           case EXPR_PPC:
 338             WALK_SUBEXPR ((*e)->value.compcall.base_object);
 339             for (a = (*e)->value.compcall.actual; a; a = a->next)
 340               WALK_SUBEXPR (a->expr);
 341             break;
 342           default:
 343             break;
 344           }
 345       return 0;
 346     }
 347   return 0;
 348 }
 349
 350 #define WALK_SUBCODE(NODE) \
 351   do                                                            \
 352     {                                                           \
 353       result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
 354       if (result)                                               \
 355         return result;                                          \
 356     }                                                           \
 357   while (0)
 358
 359 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
 360    on each expression in it.  If any of the hooks returns non-zero, that
 361    value is immediately returned.  If the hook sets *WALK_SUBTREES to 0,
 362    no subcodes or subexpressions are traversed.  */
 363
 364 int
 365 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
 366                  void *data)
 367 {
 368   for (; *c; c = &(*c)->next)
 369     {
 370       int walk_subtrees = 1;
 371       int result = codefn (c, &walk_subtrees, data);
 372       if (result)
 373         return result;
 374       if (walk_subtrees)
 375         {
 376           gfc_code *b;
 377           switch ((*c)->op)
 378             {
 379             case EXEC_DO:
 380               WALK_SUBEXPR ((*c)->ext.iterator->var);
 381               WALK_SUBEXPR ((*c)->ext.iterator->start);
 382               WALK_SUBEXPR ((*c)->ext.iterator->end);
 383               WALK_SUBEXPR ((*c)->ext.iterator->step);
 384               break;
 385             case EXEC_SELECT:
 386               WALK_SUBEXPR ((*c)->expr1);
 387               for (b = (*c)->block; b; b = b->block)
 388                 {
 389                   gfc_case *cp;
 390                   for (cp = b->ext.case_list; cp; cp = cp->next)
 391                     {
 392                       WALK_SUBEXPR (cp->low);
 393                       WALK_SUBEXPR (cp->high);
 394                     }
 395                   WALK_SUBCODE (b->next);
 396                 }
 397               continue;
 398             case EXEC_ALLOCATE:
 399             case EXEC_DEALLOCATE:
 400               {
 401                 gfc_alloc *a;
 402                 for (a = (*c)->ext.alloc.list; a; a = a->next)
 403                   WALK_SUBEXPR (a->expr);
 404                 break;
 405               }
 406             case EXEC_FORALL:
 407               {
 408                 gfc_forall_iterator *fa;
 409                 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
 410                   {
 411                     WALK_SUBEXPR (fa->var);
 412                     WALK_SUBEXPR (fa->start);
 413                     WALK_SUBEXPR (fa->end);
 414                     WALK_SUBEXPR (fa->stride);
 415                   }
 416                 break;
 417               }
 418             case EXEC_OPEN:
 419               WALK_SUBEXPR ((*c)->ext.open->unit);
 420               WALK_SUBEXPR ((*c)->ext.open->file);
 421               WALK_SUBEXPR ((*c)->ext.open->status);
 422               WALK_SUBEXPR ((*c)->ext.open->access);
 423               WALK_SUBEXPR ((*c)->ext.open->form);
 424               WALK_SUBEXPR ((*c)->ext.open->recl);
 425               WALK_SUBEXPR ((*c)->ext.open->blank);
 426               WALK_SUBEXPR ((*c)->ext.open->position);
 427               WALK_SUBEXPR ((*c)->ext.open->action);
 428               WALK_SUBEXPR ((*c)->ext.open->delim);
 429               WALK_SUBEXPR ((*c)->ext.open->pad);
 430               WALK_SUBEXPR ((*c)->ext.open->iostat);
 431               WALK_SUBEXPR ((*c)->ext.open->iomsg);
 432               WALK_SUBEXPR ((*c)->ext.open->convert);
 433               WALK_SUBEXPR ((*c)->ext.open->decimal);
 434               WALK_SUBEXPR ((*c)->ext.open->encoding);
 435               WALK_SUBEXPR ((*c)->ext.open->round);
 436               WALK_SUBEXPR ((*c)->ext.open->sign);
 437               WALK_SUBEXPR ((*c)->ext.open->asynchronous);
 438               WALK_SUBEXPR ((*c)->ext.open->id);
 439               WALK_SUBEXPR ((*c)->ext.open->newunit);
 440               break;
 441             case EXEC_CLOSE:
 442               WALK_SUBEXPR ((*c)->ext.close->unit);
 443               WALK_SUBEXPR ((*c)->ext.close->status);
 444               WALK_SUBEXPR ((*c)->ext.close->iostat);
 445               WALK_SUBEXPR ((*c)->ext.close->iomsg);
 446               break;
 447             case EXEC_BACKSPACE:
 448             case EXEC_ENDFILE:
 449             case EXEC_REWIND:
 450             case EXEC_FLUSH:
 451               WALK_SUBEXPR ((*c)->ext.filepos->unit);
 452               WALK_SUBEXPR ((*c)->ext.filepos->iostat);
 453               WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
 454               break;
 455             case EXEC_INQUIRE:
 456               WALK_SUBEXPR ((*c)->ext.inquire->unit);
 457               WALK_SUBEXPR ((*c)->ext.inquire->file);
 458               WALK_SUBEXPR ((*c)->ext.inquire->iomsg);
 459               WALK_SUBEXPR ((*c)->ext.inquire->iostat);
 460               WALK_SUBEXPR ((*c)->ext.inquire->exist);
 461               WALK_SUBEXPR ((*c)->ext.inquire->opened);
 462               WALK_SUBEXPR ((*c)->ext.inquire->number);
 463               WALK_SUBEXPR ((*c)->ext.inquire->named);
 464               WALK_SUBEXPR ((*c)->ext.inquire->name);
 465               WALK_SUBEXPR ((*c)->ext.inquire->access);
 466               WALK_SUBEXPR ((*c)->ext.inquire->sequential);
 467               WALK_SUBEXPR ((*c)->ext.inquire->direct);
 468               WALK_SUBEXPR ((*c)->ext.inquire->form);
 469               WALK_SUBEXPR ((*c)->ext.inquire->formatted);
 470               WALK_SUBEXPR ((*c)->ext.inquire->unformatted);
 471               WALK_SUBEXPR ((*c)->ext.inquire->recl);
 472               WALK_SUBEXPR ((*c)->ext.inquire->nextrec);
 473               WALK_SUBEXPR ((*c)->ext.inquire->blank);
 474               WALK_SUBEXPR ((*c)->ext.inquire->position);
 475               WALK_SUBEXPR ((*c)->ext.inquire->action);
 476               WALK_SUBEXPR ((*c)->ext.inquire->read);
 477               WALK_SUBEXPR ((*c)->ext.inquire->write);
 478               WALK_SUBEXPR ((*c)->ext.inquire->readwrite);
 479               WALK_SUBEXPR ((*c)->ext.inquire->delim);
 480               WALK_SUBEXPR ((*c)->ext.inquire->encoding);
 481               WALK_SUBEXPR ((*c)->ext.inquire->pad);
 482               WALK_SUBEXPR ((*c)->ext.inquire->iolength);
 483               WALK_SUBEXPR ((*c)->ext.inquire->convert);
 484               WALK_SUBEXPR ((*c)->ext.inquire->strm_pos);
 485               WALK_SUBEXPR ((*c)->ext.inquire->asynchronous);
 486               WALK_SUBEXPR ((*c)->ext.inquire->decimal);
 487               WALK_SUBEXPR ((*c)->ext.inquire->pending);
 488               WALK_SUBEXPR ((*c)->ext.inquire->id);
 489               WALK_SUBEXPR ((*c)->ext.inquire->sign);
 490               WALK_SUBEXPR ((*c)->ext.inquire->size);
 491               WALK_SUBEXPR ((*c)->ext.inquire->round);
 492               break;
 493             case EXEC_WAIT:
 494               WALK_SUBEXPR ((*c)->ext.wait->unit);
 495               WALK_SUBEXPR ((*c)->ext.wait->iostat);
 496               WALK_SUBEXPR ((*c)->ext.wait->iomsg);
 497               WALK_SUBEXPR ((*c)->ext.wait->id);
 498               break;
 499             case EXEC_READ:
 500             case EXEC_WRITE:
 501               WALK_SUBEXPR ((*c)->ext.dt->io_unit);
 502               WALK_SUBEXPR ((*c)->ext.dt->format_expr);
 503               WALK_SUBEXPR ((*c)->ext.dt->rec);
 504               WALK_SUBEXPR ((*c)->ext.dt->advance);
 505               WALK_SUBEXPR ((*c)->ext.dt->iostat);
 506               WALK_SUBEXPR ((*c)->ext.dt->size);
 507               WALK_SUBEXPR ((*c)->ext.dt->iomsg);
 508               WALK_SUBEXPR ((*c)->ext.dt->id);
 509               WALK_SUBEXPR ((*c)->ext.dt->pos);
 510               WALK_SUBEXPR ((*c)->ext.dt->asynchronous);
 511               WALK_SUBEXPR ((*c)->ext.dt->blank);
 512               WALK_SUBEXPR ((*c)->ext.dt->decimal);
 513               WALK_SUBEXPR ((*c)->ext.dt->delim);
 514               WALK_SUBEXPR ((*c)->ext.dt->pad);
 515               WALK_SUBEXPR ((*c)->ext.dt->round);
 516               WALK_SUBEXPR ((*c)->ext.dt->sign);
 517               WALK_SUBEXPR ((*c)->ext.dt->extra_comma);
 518               break;
 519             case EXEC_OMP_DO:
 520             case EXEC_OMP_PARALLEL:
 521             case EXEC_OMP_PARALLEL_DO:
 522             case EXEC_OMP_PARALLEL_SECTIONS:
 523             case EXEC_OMP_PARALLEL_WORKSHARE:
 524             case EXEC_OMP_SECTIONS:
 525             case EXEC_OMP_SINGLE:
 526             case EXEC_OMP_WORKSHARE:
 527             case EXEC_OMP_END_SINGLE:
 528             case EXEC_OMP_TASK:
 529               if ((*c)->ext.omp_clauses)
 530                 {
 531                   WALK_SUBEXPR ((*c)->ext.omp_clauses->if_expr);
 532                   WALK_SUBEXPR ((*c)->ext.omp_clauses->num_threads);
 533                   WALK_SUBEXPR ((*c)->ext.omp_clauses->chunk_size);
 534                 }
 535               break;
 536             default:
 537               break;
 538             }
 539           WALK_SUBEXPR ((*c)->expr1);
 540           WALK_SUBEXPR ((*c)->expr2);
 541           WALK_SUBEXPR ((*c)->expr3);
 542           for (b = (*c)->block; b; b = b->block)
 543             {
 544               WALK_SUBEXPR (b->expr1);
 545               WALK_SUBEXPR (b->expr2);
 546               WALK_SUBCODE (b->next);
 547             }
 548         }
 549     }
 550   return 0;
 551 }