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.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)))
137 /* Insert a new assignment statement after the current one. */
138 n = XCNEW (gfc_code);
144 n->expr1 = gfc_copy_expr (c->expr1);
146 new_expr = gfc_copy_expr (c->expr1);
154 /* Nothing to optimize. */
158 /* Optimizations for an assignment. */
161 optimize_assignment (gfc_code * c)
168 /* Optimize away a = trim(b), where a is a character variable. */
170 if (lhs->ts.type == BT_CHARACTER)
172 if (rhs->expr_type == EXPR_FUNCTION &&
173 rhs->value.function.isym &&
174 rhs->value.function.isym->id == GFC_ISYM_TRIM)
176 strip_function_call (rhs);
177 optimize_assignment (c);
182 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
183 optimize_binop_array_assignment (c, &rhs, false);
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. */
192 strip_function_call (gfc_expr *e)
195 gfc_actual_arglist *a;
197 a = e->value.function.actual;
199 /* We should have at least one argument. */
200 gcc_assert (a->expr != NULL);
204 /* Free the remaining arglist, if any. */
206 gfc_free_actual_arglist (a->next);
208 /* Graft the argument expression onto the original function. */
214 /* Recursive optimization of operators. */
217 optimize_op (gfc_expr *e)
219 gfc_intrinsic_op op = e->value.op.op;
224 case INTRINSIC_EQ_OS:
226 case INTRINSIC_GE_OS:
228 case INTRINSIC_LE_OS:
229 return optimize_equality (e, true);
232 case INTRINSIC_NE_OS:
234 case INTRINSIC_GT_OS:
236 case INTRINSIC_LT_OS:
237 return optimize_equality (e, false);
246 /* Optimize expressions for equality. */
249 optimize_equality (gfc_expr *e, bool equal)
254 op1 = e->value.op.op1;
255 op2 = e->value.op.op2;
257 /* Strip off unneeded TRIM calls from string comparisons. */
261 if (op1->expr_type == EXPR_FUNCTION
262 && op1->value.function.isym
263 && op1->value.function.isym->id == GFC_ISYM_TRIM)
265 strip_function_call (op1);
269 if (op2->expr_type == EXPR_FUNCTION
270 && op2->value.function.isym
271 && op2->value.function.isym->id == GFC_ISYM_TRIM)
273 strip_function_call (op2);
279 optimize_equality (e, equal);
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. */
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))
298 /* Replace the expression by a constant expression. The typespec
299 and where remains the way it is. */
302 e->expr_type = EXPR_CONSTANT;
303 e->value.logical = equal;
309 #define WALK_SUBEXPR(NODE) \
312 result = gfc_expr_walker (&(NODE), exprfn, data); \
317 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
319 /* Walk expression *E, calling EXPRFN on each expression in it. */
322 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
326 int walk_subtrees = 1;
327 gfc_actual_arglist *a;
331 int result = exprfn (e, &walk_subtrees, data);
335 switch ((*e)->expr_type)
338 WALK_SUBEXPR ((*e)->value.op.op1);
339 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
342 for (a = (*e)->value.function.actual; a; a = a->next)
343 WALK_SUBEXPR (a->expr);
347 WALK_SUBEXPR ((*e)->value.compcall.base_object);
348 for (a = (*e)->value.compcall.actual; a; a = a->next)
349 WALK_SUBEXPR (a->expr);
354 for (c = gfc_constructor_first ((*e)->value.constructor); c;
355 c = gfc_constructor_next (c))
357 WALK_SUBEXPR (c->expr);
358 if (c->iterator != NULL)
360 WALK_SUBEXPR (c->iterator->var);
361 WALK_SUBEXPR (c->iterator->start);
362 WALK_SUBEXPR (c->iterator->end);
363 WALK_SUBEXPR (c->iterator->step);
367 if ((*e)->expr_type != EXPR_ARRAY)
370 /* Fall through to the variable case in order to walk the
375 for (r = (*e)->ref; r; r = r->next)
384 if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
386 for (i=0; i< ar->dimen; i++)
388 WALK_SUBEXPR (ar->start[i]);
389 WALK_SUBEXPR (ar->end[i]);
390 WALK_SUBEXPR (ar->stride[i]);
397 WALK_SUBEXPR (r->u.ss.start);
398 WALK_SUBEXPR (r->u.ss.end);
414 #define WALK_SUBCODE(NODE) \
417 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
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. */
429 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
432 for (; *c; c = &(*c)->next)
434 int walk_subtrees = 1;
435 int result = codefn (c, &walk_subtrees, data);
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);
450 WALK_SUBEXPR ((*c)->expr1);
451 for (b = (*c)->block; b; b = b->block)
454 for (cp = b->ext.case_list; cp; cp = cp->next)
456 WALK_SUBEXPR (cp->low);
457 WALK_SUBEXPR (cp->high);
459 WALK_SUBCODE (b->next);
463 case EXEC_DEALLOCATE:
466 for (a = (*c)->ext.alloc.list; a; a = a->next)
467 WALK_SUBEXPR (a->expr);
472 gfc_forall_iterator *fa;
473 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
475 WALK_SUBEXPR (fa->var);
476 WALK_SUBEXPR (fa->start);
477 WALK_SUBEXPR (fa->end);
478 WALK_SUBEXPR (fa->stride);
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);
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);
515 WALK_SUBEXPR ((*c)->ext.filepos->unit);
516 WALK_SUBEXPR ((*c)->ext.filepos->iostat);
517 WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
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);
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);
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);
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:
593 if ((*c)->ext.omp_clauses)
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);
603 WALK_SUBEXPR ((*c)->expr1);
604 WALK_SUBEXPR ((*c)->expr2);
605 WALK_SUBEXPR ((*c)->expr3);
606 for (b = (*c)->block; b; b = b->block)
608 WALK_SUBEXPR (b->expr1);
609 WALK_SUBEXPR (b->expr2);
610 WALK_SUBCODE (b->next);