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