1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
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
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
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/>. */
26 #include "dependency.h"
27 #include "constructor.h"
29 /* Forward declarations. */
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);
37 /* Entry point - run all passes for a namespace. So far, only an
38 optimization pass is run. */
41 gfc_run_passes (gfc_namespace *ns)
44 optimize_namespace (ns);
47 /* Callback for each gfc_code node invoked through gfc_code_walker
48 from optimize_namespace. */
51 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
52 void *data ATTRIBUTE_UNUSED)
54 if ((*c)->op == EXEC_ASSIGN)
55 optimize_assignment (*c);
59 /* Callback for each gfc_expr node invoked through gfc_code_walker
60 from optimize_namespace. */
63 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
64 void *data ATTRIBUTE_UNUSED)
66 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
67 gfc_simplify_expr (*e, 0);
71 /* Optimize a namespace, including all contained namespaces. */
74 optimize_namespace (gfc_namespace *ns)
76 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
78 for (ns = ns->contained; ns; ns = ns->sibling)
79 optimize_namespace (ns);
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.
91 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
96 if (e->expr_type == EXPR_OP)
98 switch (e->value.op.op)
100 /* Unary operators and exponentiation: Only look at a single
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))
112 /* Binary operators. */
113 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
116 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
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))
132 /* Insert a new assignment statement after the current one. */
133 n = XCNEW (gfc_code);
139 n->expr1 = gfc_copy_expr (c->expr1);
141 new_expr = gfc_copy_expr (c->expr1);
149 /* Nothing to optimize. */
153 /* Optimizations for an assignment. */
156 optimize_assignment (gfc_code * c)
163 /* Optimize away a = trim(b), where a is a character variable. */
165 if (lhs->ts.type == BT_CHARACTER)
167 if (rhs->expr_type == EXPR_FUNCTION &&
168 rhs->value.function.isym &&
169 rhs->value.function.isym->id == GFC_ISYM_TRIM)
171 strip_function_call (rhs);
172 optimize_assignment (c);
177 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
178 optimize_binop_array_assignment (c, &rhs, false);
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. */
187 strip_function_call (gfc_expr *e)
190 gfc_actual_arglist *a;
192 a = e->value.function.actual;
194 /* We should have at least one argument. */
195 gcc_assert (a->expr != NULL);
199 /* Free the remaining arglist, if any. */
201 gfc_free_actual_arglist (a->next);
203 /* Graft the argument expression onto the original function. */
209 /* Recursive optimization of operators. */
212 optimize_op (gfc_expr *e)
214 gfc_intrinsic_op op = e->value.op.op;
219 case INTRINSIC_EQ_OS:
221 case INTRINSIC_GE_OS:
223 case INTRINSIC_LE_OS:
224 return optimize_equality (e, true);
227 case INTRINSIC_NE_OS:
229 case INTRINSIC_GT_OS:
231 case INTRINSIC_LT_OS:
232 return optimize_equality (e, false);
241 /* Optimize expressions for equality. */
244 optimize_equality (gfc_expr *e, bool equal)
249 op1 = e->value.op.op1;
250 op2 = e->value.op.op2;
252 /* Strip off unneeded TRIM calls from string comparisons. */
256 if (op1->expr_type == EXPR_FUNCTION
257 && op1->value.function.isym
258 && op1->value.function.isym->id == GFC_ISYM_TRIM)
260 strip_function_call (op1);
264 if (op2->expr_type == EXPR_FUNCTION
265 && op2->value.function.isym
266 && op2->value.function.isym->id == GFC_ISYM_TRIM)
268 strip_function_call (op2);
274 optimize_equality (e, equal);
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. */
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))
293 /* Replace the expression by a constant expression. The typespec
294 and where remains the way it is. */
297 e->expr_type = EXPR_CONSTANT;
298 e->value.logical = equal;
304 #define WALK_SUBEXPR(NODE) \
307 result = gfc_expr_walker (&(NODE), exprfn, data); \
312 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
314 /* Walk expression *E, calling EXPRFN on each expression in it. */
317 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
321 int walk_subtrees = 1;
322 gfc_actual_arglist *a;
326 int result = exprfn (e, &walk_subtrees, data);
330 switch ((*e)->expr_type)
333 WALK_SUBEXPR ((*e)->value.op.op1);
334 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
337 for (a = (*e)->value.function.actual; a; a = a->next)
338 WALK_SUBEXPR (a->expr);
342 WALK_SUBEXPR ((*e)->value.compcall.base_object);
343 for (a = (*e)->value.compcall.actual; a; a = a->next)
344 WALK_SUBEXPR (a->expr);
349 for (c = gfc_constructor_first ((*e)->value.constructor); c;
350 c = gfc_constructor_next (c))
352 WALK_SUBEXPR (c->expr);
353 if (c->iterator != NULL)
355 WALK_SUBEXPR (c->iterator->var);
356 WALK_SUBEXPR (c->iterator->start);
357 WALK_SUBEXPR (c->iterator->end);
358 WALK_SUBEXPR (c->iterator->step);
362 if ((*e)->expr_type != EXPR_ARRAY)
365 /* Fall through to the variable case in order to walk the
369 for (r = (*e)->ref; r; r = r->next)
378 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
380 for (i=0; i< ar->dimen; i++)
382 WALK_SUBEXPR (ar->start[i]);
383 WALK_SUBEXPR (ar->end[i]);
384 WALK_SUBEXPR (ar->stride[i]);
391 WALK_SUBEXPR (r->u.ss.start);
392 WALK_SUBEXPR (r->u.ss.end);
408 #define WALK_SUBCODE(NODE) \
411 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
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. */
423 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
426 for (; *c; c = &(*c)->next)
428 int walk_subtrees = 1;
429 int result = codefn (c, &walk_subtrees, data);
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);
444 WALK_SUBEXPR ((*c)->expr1);
445 for (b = (*c)->block; b; b = b->block)
448 for (cp = b->ext.case_list; cp; cp = cp->next)
450 WALK_SUBEXPR (cp->low);
451 WALK_SUBEXPR (cp->high);
453 WALK_SUBCODE (b->next);
457 case EXEC_DEALLOCATE:
460 for (a = (*c)->ext.alloc.list; a; a = a->next)
461 WALK_SUBEXPR (a->expr);
466 gfc_forall_iterator *fa;
467 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
469 WALK_SUBEXPR (fa->var);
470 WALK_SUBEXPR (fa->start);
471 WALK_SUBEXPR (fa->end);
472 WALK_SUBEXPR (fa->stride);
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);
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);
509 WALK_SUBEXPR ((*c)->ext.filepos->unit);
510 WALK_SUBEXPR ((*c)->ext.filepos->iostat);
511 WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
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);
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);
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);
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:
587 if ((*c)->ext.omp_clauses)
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);
597 WALK_SUBEXPR ((*c)->expr1);
598 WALK_SUBEXPR ((*c)->expr2);
599 WALK_SUBEXPR ((*c)->expr3);
600 for (b = (*c)->block; b; b = b->block)
602 WALK_SUBEXPR (b->expr1);
603 WALK_SUBEXPR (b->expr2);
604 WALK_SUBCODE (b->next);