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"
28 /* Forward declarations. */
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);
36 /* Entry point - run all passes for a namespace. So far, only an
37 optimization pass is run. */
40 gfc_run_passes (gfc_namespace *ns)
43 optimize_namespace (ns);
46 /* Callback for each gfc_code node invoked through gfc_code_walker
47 from optimize_namespace. */
50 optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
51 void *data ATTRIBUTE_UNUSED)
53 if ((*c)->op == EXEC_ASSIGN)
54 optimize_assignment (*c);
58 /* Callback for each gfc_expr node invoked through gfc_code_walker
59 from optimize_namespace. */
62 optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
63 void *data ATTRIBUTE_UNUSED)
65 if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
66 gfc_simplify_expr (*e, 0);
70 /* Optimize a namespace, including all contained namespaces. */
73 optimize_namespace (gfc_namespace *ns)
75 gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
77 for (ns = ns->contained; ns; ns = ns->sibling)
78 optimize_namespace (ns);
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.
90 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
95 if (e->expr_type == EXPR_OP)
97 switch (e->value.op.op)
99 /* Unary operators and exponentiation: Only look at a single
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))
111 /* Binary operators. */
112 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
115 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
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))
131 /* Insert a new assignment statement after the current one. */
132 n = XCNEW (gfc_code);
138 n->expr1 = gfc_copy_expr (c->expr1);
140 new_expr = gfc_copy_expr (c->expr1);
148 /* Nothing to optimize. */
152 /* Optimizations for an assignment. */
155 optimize_assignment (gfc_code * c)
162 /* Optimize away a = trim(b), where a is a character variable. */
164 if (lhs->ts.type == BT_CHARACTER)
166 if (rhs->expr_type == EXPR_FUNCTION &&
167 rhs->value.function.isym &&
168 rhs->value.function.isym->id == GFC_ISYM_TRIM)
170 strip_function_call (rhs);
171 optimize_assignment (c);
176 if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
177 optimize_binop_array_assignment (c, &rhs, false);
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. */
186 strip_function_call (gfc_expr *e)
189 gfc_actual_arglist *a;
191 a = e->value.function.actual;
193 /* We should have at least one argument. */
194 gcc_assert (a->expr != NULL);
198 /* Free the remaining arglist, if any. */
200 gfc_free_actual_arglist (a->next);
202 /* Graft the argument expression onto the original function. */
208 /* Recursive optimization of operators. */
211 optimize_op (gfc_expr *e)
213 gfc_intrinsic_op op = e->value.op.op;
218 case INTRINSIC_EQ_OS:
220 case INTRINSIC_GE_OS:
222 case INTRINSIC_LE_OS:
223 return optimize_equality (e, true);
226 case INTRINSIC_NE_OS:
228 case INTRINSIC_GT_OS:
230 case INTRINSIC_LT_OS:
231 return optimize_equality (e, false);
240 /* Optimize expressions for equality. */
243 optimize_equality (gfc_expr *e, bool equal)
248 op1 = e->value.op.op1;
249 op2 = e->value.op.op2;
251 /* Strip off unneeded TRIM calls from string comparisons. */
255 if (op1->expr_type == EXPR_FUNCTION
256 && op1->value.function.isym
257 && op1->value.function.isym->id == GFC_ISYM_TRIM)
259 strip_function_call (op1);
263 if (op2->expr_type == EXPR_FUNCTION
264 && op2->value.function.isym
265 && op2->value.function.isym->id == GFC_ISYM_TRIM)
267 strip_function_call (op2);
273 optimize_equality (e, equal);
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. */
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))
292 /* Replace the expression by a constant expression. The typespec
293 and where remains the way it is. */
296 e->expr_type = EXPR_CONSTANT;
297 e->value.logical = equal;
303 #define WALK_SUBEXPR(NODE) \
306 result = gfc_expr_walker (&(NODE), exprfn, data); \
311 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
313 /* Walk expression *E, calling EXPRFN on each expression in it. */
316 gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
320 int walk_subtrees = 1;
321 gfc_actual_arglist *a;
322 int result = exprfn (e, &walk_subtrees, data);
326 switch ((*e)->expr_type)
329 WALK_SUBEXPR ((*e)->value.op.op1);
330 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
333 for (a = (*e)->value.function.actual; a; a = a->next)
334 WALK_SUBEXPR (a->expr);
338 WALK_SUBEXPR ((*e)->value.compcall.base_object);
339 for (a = (*e)->value.compcall.actual; a; a = a->next)
340 WALK_SUBEXPR (a->expr);
350 #define WALK_SUBCODE(NODE) \
353 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
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. */
365 gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
368 for (; *c; c = &(*c)->next)
370 int walk_subtrees = 1;
371 int result = codefn (c, &walk_subtrees, data);
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);
386 WALK_SUBEXPR ((*c)->expr1);
387 for (b = (*c)->block; b; b = b->block)
390 for (cp = b->ext.case_list; cp; cp = cp->next)
392 WALK_SUBEXPR (cp->low);
393 WALK_SUBEXPR (cp->high);
395 WALK_SUBCODE (b->next);
399 case EXEC_DEALLOCATE:
402 for (a = (*c)->ext.alloc.list; a; a = a->next)
403 WALK_SUBEXPR (a->expr);
408 gfc_forall_iterator *fa;
409 for (fa = (*c)->ext.forall_iterator; fa; fa = fa->next)
411 WALK_SUBEXPR (fa->var);
412 WALK_SUBEXPR (fa->start);
413 WALK_SUBEXPR (fa->end);
414 WALK_SUBEXPR (fa->stride);
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);
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);
451 WALK_SUBEXPR ((*c)->ext.filepos->unit);
452 WALK_SUBEXPR ((*c)->ext.filepos->iostat);
453 WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
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);
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);
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);
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:
529 if ((*c)->ext.omp_clauses)
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);
539 WALK_SUBEXPR ((*c)->expr1);
540 WALK_SUBEXPR ((*c)->expr2);
541 WALK_SUBEXPR ((*c)->expr3);
542 for (b = (*c)->block; b; b = b->block)
544 WALK_SUBEXPR (b->expr1);
545 WALK_SUBEXPR (b->expr2);
546 WALK_SUBCODE (b->next);