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