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"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
38 /* Entry point - run all passes for a namespace. So far, only an
39 optimization pass is run. */
42 gfc_run_passes (gfc_namespace
*ns
)
46 optimize_namespace (ns
);
47 if (gfc_option
.dump_fortran_optimized
)
48 gfc_dump_parse_tree (ns
, stdout
);
52 /* Callback for each gfc_code node invoked through gfc_code_walker
53 from optimize_namespace. */
56 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
57 void *data ATTRIBUTE_UNUSED
)
59 if ((*c
)->op
== EXEC_ASSIGN
)
60 optimize_assignment (*c
);
64 /* Callback for each gfc_expr node invoked through gfc_code_walker
65 from optimize_namespace. */
68 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
69 void *data ATTRIBUTE_UNUSED
)
71 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
72 gfc_simplify_expr (*e
, 0);
76 /* Optimize a namespace, including all contained namespaces. */
79 optimize_namespace (gfc_namespace
*ns
)
81 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
83 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
84 optimize_namespace (ns
);
90 a = matmul(b,c) ; a = a + d
91 where the array function is not elemental and not allocatable
92 and does not depend on the left-hand side.
96 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
101 if (e
->expr_type
== EXPR_OP
)
103 switch (e
->value
.op
.op
)
105 /* Unary operators and exponentiation: Only look at a single
108 case INTRINSIC_UPLUS
:
109 case INTRINSIC_UMINUS
:
110 case INTRINSIC_PARENTHESES
:
111 case INTRINSIC_POWER
:
112 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
117 /* Binary operators. */
118 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
121 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
127 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
128 && ! (e
->value
.function
.esym
129 && (e
->value
.function
.esym
->attr
.elemental
130 || e
->value
.function
.esym
->attr
.allocatable
131 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
132 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
133 && ! (e
->value
.function
.isym
134 && (e
->value
.function
.isym
->elemental
135 || e
->ts
.type
!= c
->expr1
->ts
.type
136 || e
->ts
.kind
!= c
->expr1
->ts
.kind
)))
142 /* Insert a new assignment statement after the current one. */
143 n
= XCNEW (gfc_code
);
149 n
->expr1
= gfc_copy_expr (c
->expr1
);
151 new_expr
= gfc_copy_expr (c
->expr1
);
159 /* Nothing to optimize. */
163 /* Optimizations for an assignment. */
166 optimize_assignment (gfc_code
* c
)
173 /* Optimize away a = trim(b), where a is a character variable. */
175 if (lhs
->ts
.type
== BT_CHARACTER
)
177 if (rhs
->expr_type
== EXPR_FUNCTION
&&
178 rhs
->value
.function
.isym
&&
179 rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
181 strip_function_call (rhs
);
182 optimize_assignment (c
);
187 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
188 optimize_binop_array_assignment (c
, &rhs
, false);
192 /* Remove an unneeded function call, modifying the expression.
193 This replaces the function call with the value of its
194 first argument. The rest of the argument list is freed. */
197 strip_function_call (gfc_expr
*e
)
200 gfc_actual_arglist
*a
;
202 a
= e
->value
.function
.actual
;
204 /* We should have at least one argument. */
205 gcc_assert (a
->expr
!= NULL
);
209 /* Free the remaining arglist, if any. */
211 gfc_free_actual_arglist (a
->next
);
213 /* Graft the argument expression onto the original function. */
219 /* Recursive optimization of operators. */
222 optimize_op (gfc_expr
*e
)
224 gfc_intrinsic_op op
= e
->value
.op
.op
;
229 case INTRINSIC_EQ_OS
:
231 case INTRINSIC_GE_OS
:
233 case INTRINSIC_LE_OS
:
235 case INTRINSIC_NE_OS
:
237 case INTRINSIC_GT_OS
:
239 case INTRINSIC_LT_OS
:
240 return optimize_comparison (e
, op
);
249 /* Optimize expressions for equality. */
252 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
259 op1
= e
->value
.op
.op1
;
260 op2
= e
->value
.op
.op2
;
262 /* Strip off unneeded TRIM calls from string comparisons. */
266 if (op1
->expr_type
== EXPR_FUNCTION
267 && op1
->value
.function
.isym
268 && op1
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
270 strip_function_call (op1
);
274 if (op2
->expr_type
== EXPR_FUNCTION
275 && op2
->value
.function
.isym
276 && op2
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
278 strip_function_call (op2
);
284 optimize_comparison (e
, op
);
288 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
289 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
290 handles them well). However, there are also cases that need a non-scalar
291 argument. For example the any intrinsic. See PR 45380. */
295 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
297 if (flag_finite_math_only
298 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
299 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
301 eq
= gfc_dep_compare_expr (op1
, op2
);
304 /* Replace A // B < A // C with B < C, and A // B < C // B
306 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
307 && op1
->value
.op
.op
== INTRINSIC_CONCAT
308 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
310 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
311 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
312 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
313 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
315 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
317 /* Watch out for 'A ' // x vs. 'A' // x. */
319 if (op1_left
->expr_type
== EXPR_CONSTANT
320 && op2_left
->expr_type
== EXPR_CONSTANT
321 && op1_left
->value
.character
.length
322 != op2_left
->value
.character
.length
)
328 e
->value
.op
.op1
= op1_right
;
329 e
->value
.op
.op2
= op2_right
;
330 optimize_comparison (e
, op
);
334 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
336 gfc_free (op1_right
);
337 gfc_free (op2_right
);
338 e
->value
.op
.op1
= op1_left
;
339 e
->value
.op
.op2
= op2_left
;
340 optimize_comparison (e
, op
);
347 /* eq can only be -1, 0 or 1 at this point. */
351 case INTRINSIC_EQ_OS
:
356 case INTRINSIC_GE_OS
:
361 case INTRINSIC_LE_OS
:
366 case INTRINSIC_NE_OS
:
371 case INTRINSIC_GT_OS
:
376 case INTRINSIC_LT_OS
:
381 gfc_internal_error ("illegal OP in optimize_comparison");
385 /* Replace the expression by a constant expression. The typespec
386 and where remains the way it is. */
389 e
->expr_type
= EXPR_CONSTANT
;
390 e
->value
.logical
= result
;
398 #define WALK_SUBEXPR(NODE) \
401 result = gfc_expr_walker (&(NODE), exprfn, data); \
406 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
408 /* Walk expression *E, calling EXPRFN on each expression in it. */
411 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
415 int walk_subtrees
= 1;
416 gfc_actual_arglist
*a
;
420 int result
= exprfn (e
, &walk_subtrees
, data
);
424 switch ((*e
)->expr_type
)
427 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
428 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
431 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
432 WALK_SUBEXPR (a
->expr
);
436 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
437 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
438 WALK_SUBEXPR (a
->expr
);
443 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
444 c
= gfc_constructor_next (c
))
446 WALK_SUBEXPR (c
->expr
);
447 if (c
->iterator
!= NULL
)
449 WALK_SUBEXPR (c
->iterator
->var
);
450 WALK_SUBEXPR (c
->iterator
->start
);
451 WALK_SUBEXPR (c
->iterator
->end
);
452 WALK_SUBEXPR (c
->iterator
->step
);
456 if ((*e
)->expr_type
!= EXPR_ARRAY
)
459 /* Fall through to the variable case in order to walk the
464 for (r
= (*e
)->ref
; r
; r
= r
->next
)
473 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
475 for (i
=0; i
< ar
->dimen
; i
++)
477 WALK_SUBEXPR (ar
->start
[i
]);
478 WALK_SUBEXPR (ar
->end
[i
]);
479 WALK_SUBEXPR (ar
->stride
[i
]);
486 WALK_SUBEXPR (r
->u
.ss
.start
);
487 WALK_SUBEXPR (r
->u
.ss
.end
);
503 #define WALK_SUBCODE(NODE) \
506 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
512 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
513 on each expression in it. If any of the hooks returns non-zero, that
514 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
515 no subcodes or subexpressions are traversed. */
518 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
521 for (; *c
; c
= &(*c
)->next
)
523 int walk_subtrees
= 1;
524 int result
= codefn (c
, &walk_subtrees
, data
);
531 gfc_actual_arglist
*a
;
536 WALK_SUBEXPR ((*c
)->ext
.iterator
->var
);
537 WALK_SUBEXPR ((*c
)->ext
.iterator
->start
);
538 WALK_SUBEXPR ((*c
)->ext
.iterator
->end
);
539 WALK_SUBEXPR ((*c
)->ext
.iterator
->step
);
543 case EXEC_ASSIGN_CALL
:
544 for (a
= (*c
)->ext
.actual
; a
; a
= a
->next
)
545 WALK_SUBEXPR (a
->expr
);
549 WALK_SUBEXPR ((*c
)->expr1
);
550 for (a
= (*c
)->ext
.actual
; a
; a
= a
->next
)
551 WALK_SUBEXPR (a
->expr
);
555 WALK_SUBEXPR ((*c
)->expr1
);
556 for (b
= (*c
)->block
; b
; b
= b
->block
)
559 for (cp
= b
->ext
.case_list
; cp
; cp
= cp
->next
)
561 WALK_SUBEXPR (cp
->low
);
562 WALK_SUBEXPR (cp
->high
);
564 WALK_SUBCODE (b
->next
);
569 case EXEC_DEALLOCATE
:
572 for (a
= (*c
)->ext
.alloc
.list
; a
; a
= a
->next
)
573 WALK_SUBEXPR (a
->expr
);
579 gfc_forall_iterator
*fa
;
580 for (fa
= (*c
)->ext
.forall_iterator
; fa
; fa
= fa
->next
)
582 WALK_SUBEXPR (fa
->var
);
583 WALK_SUBEXPR (fa
->start
);
584 WALK_SUBEXPR (fa
->end
);
585 WALK_SUBEXPR (fa
->stride
);
591 WALK_SUBEXPR ((*c
)->ext
.open
->unit
);
592 WALK_SUBEXPR ((*c
)->ext
.open
->file
);
593 WALK_SUBEXPR ((*c
)->ext
.open
->status
);
594 WALK_SUBEXPR ((*c
)->ext
.open
->access
);
595 WALK_SUBEXPR ((*c
)->ext
.open
->form
);
596 WALK_SUBEXPR ((*c
)->ext
.open
->recl
);
597 WALK_SUBEXPR ((*c
)->ext
.open
->blank
);
598 WALK_SUBEXPR ((*c
)->ext
.open
->position
);
599 WALK_SUBEXPR ((*c
)->ext
.open
->action
);
600 WALK_SUBEXPR ((*c
)->ext
.open
->delim
);
601 WALK_SUBEXPR ((*c
)->ext
.open
->pad
);
602 WALK_SUBEXPR ((*c
)->ext
.open
->iostat
);
603 WALK_SUBEXPR ((*c
)->ext
.open
->iomsg
);
604 WALK_SUBEXPR ((*c
)->ext
.open
->convert
);
605 WALK_SUBEXPR ((*c
)->ext
.open
->decimal
);
606 WALK_SUBEXPR ((*c
)->ext
.open
->encoding
);
607 WALK_SUBEXPR ((*c
)->ext
.open
->round
);
608 WALK_SUBEXPR ((*c
)->ext
.open
->sign
);
609 WALK_SUBEXPR ((*c
)->ext
.open
->asynchronous
);
610 WALK_SUBEXPR ((*c
)->ext
.open
->id
);
611 WALK_SUBEXPR ((*c
)->ext
.open
->newunit
);
615 WALK_SUBEXPR ((*c
)->ext
.close
->unit
);
616 WALK_SUBEXPR ((*c
)->ext
.close
->status
);
617 WALK_SUBEXPR ((*c
)->ext
.close
->iostat
);
618 WALK_SUBEXPR ((*c
)->ext
.close
->iomsg
);
625 WALK_SUBEXPR ((*c
)->ext
.filepos
->unit
);
626 WALK_SUBEXPR ((*c
)->ext
.filepos
->iostat
);
627 WALK_SUBEXPR ((*c
)->ext
.filepos
->iomsg
);
631 WALK_SUBEXPR ((*c
)->ext
.inquire
->unit
);
632 WALK_SUBEXPR ((*c
)->ext
.inquire
->file
);
633 WALK_SUBEXPR ((*c
)->ext
.inquire
->iomsg
);
634 WALK_SUBEXPR ((*c
)->ext
.inquire
->iostat
);
635 WALK_SUBEXPR ((*c
)->ext
.inquire
->exist
);
636 WALK_SUBEXPR ((*c
)->ext
.inquire
->opened
);
637 WALK_SUBEXPR ((*c
)->ext
.inquire
->number
);
638 WALK_SUBEXPR ((*c
)->ext
.inquire
->named
);
639 WALK_SUBEXPR ((*c
)->ext
.inquire
->name
);
640 WALK_SUBEXPR ((*c
)->ext
.inquire
->access
);
641 WALK_SUBEXPR ((*c
)->ext
.inquire
->sequential
);
642 WALK_SUBEXPR ((*c
)->ext
.inquire
->direct
);
643 WALK_SUBEXPR ((*c
)->ext
.inquire
->form
);
644 WALK_SUBEXPR ((*c
)->ext
.inquire
->formatted
);
645 WALK_SUBEXPR ((*c
)->ext
.inquire
->unformatted
);
646 WALK_SUBEXPR ((*c
)->ext
.inquire
->recl
);
647 WALK_SUBEXPR ((*c
)->ext
.inquire
->nextrec
);
648 WALK_SUBEXPR ((*c
)->ext
.inquire
->blank
);
649 WALK_SUBEXPR ((*c
)->ext
.inquire
->position
);
650 WALK_SUBEXPR ((*c
)->ext
.inquire
->action
);
651 WALK_SUBEXPR ((*c
)->ext
.inquire
->read
);
652 WALK_SUBEXPR ((*c
)->ext
.inquire
->write
);
653 WALK_SUBEXPR ((*c
)->ext
.inquire
->readwrite
);
654 WALK_SUBEXPR ((*c
)->ext
.inquire
->delim
);
655 WALK_SUBEXPR ((*c
)->ext
.inquire
->encoding
);
656 WALK_SUBEXPR ((*c
)->ext
.inquire
->pad
);
657 WALK_SUBEXPR ((*c
)->ext
.inquire
->iolength
);
658 WALK_SUBEXPR ((*c
)->ext
.inquire
->convert
);
659 WALK_SUBEXPR ((*c
)->ext
.inquire
->strm_pos
);
660 WALK_SUBEXPR ((*c
)->ext
.inquire
->asynchronous
);
661 WALK_SUBEXPR ((*c
)->ext
.inquire
->decimal
);
662 WALK_SUBEXPR ((*c
)->ext
.inquire
->pending
);
663 WALK_SUBEXPR ((*c
)->ext
.inquire
->id
);
664 WALK_SUBEXPR ((*c
)->ext
.inquire
->sign
);
665 WALK_SUBEXPR ((*c
)->ext
.inquire
->size
);
666 WALK_SUBEXPR ((*c
)->ext
.inquire
->round
);
670 WALK_SUBEXPR ((*c
)->ext
.wait
->unit
);
671 WALK_SUBEXPR ((*c
)->ext
.wait
->iostat
);
672 WALK_SUBEXPR ((*c
)->ext
.wait
->iomsg
);
673 WALK_SUBEXPR ((*c
)->ext
.wait
->id
);
678 WALK_SUBEXPR ((*c
)->ext
.dt
->io_unit
);
679 WALK_SUBEXPR ((*c
)->ext
.dt
->format_expr
);
680 WALK_SUBEXPR ((*c
)->ext
.dt
->rec
);
681 WALK_SUBEXPR ((*c
)->ext
.dt
->advance
);
682 WALK_SUBEXPR ((*c
)->ext
.dt
->iostat
);
683 WALK_SUBEXPR ((*c
)->ext
.dt
->size
);
684 WALK_SUBEXPR ((*c
)->ext
.dt
->iomsg
);
685 WALK_SUBEXPR ((*c
)->ext
.dt
->id
);
686 WALK_SUBEXPR ((*c
)->ext
.dt
->pos
);
687 WALK_SUBEXPR ((*c
)->ext
.dt
->asynchronous
);
688 WALK_SUBEXPR ((*c
)->ext
.dt
->blank
);
689 WALK_SUBEXPR ((*c
)->ext
.dt
->decimal
);
690 WALK_SUBEXPR ((*c
)->ext
.dt
->delim
);
691 WALK_SUBEXPR ((*c
)->ext
.dt
->pad
);
692 WALK_SUBEXPR ((*c
)->ext
.dt
->round
);
693 WALK_SUBEXPR ((*c
)->ext
.dt
->sign
);
694 WALK_SUBEXPR ((*c
)->ext
.dt
->extra_comma
);
698 case EXEC_OMP_PARALLEL
:
699 case EXEC_OMP_PARALLEL_DO
:
700 case EXEC_OMP_PARALLEL_SECTIONS
:
701 case EXEC_OMP_PARALLEL_WORKSHARE
:
702 case EXEC_OMP_SECTIONS
:
703 case EXEC_OMP_SINGLE
:
704 case EXEC_OMP_WORKSHARE
:
705 case EXEC_OMP_END_SINGLE
:
707 if ((*c
)->ext
.omp_clauses
)
709 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->if_expr
);
710 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->num_threads
);
711 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->chunk_size
);
718 WALK_SUBEXPR ((*c
)->expr1
);
719 WALK_SUBEXPR ((*c
)->expr2
);
720 WALK_SUBEXPR ((*c
)->expr3
);
721 for (b
= (*c
)->block
; b
; b
= b
->block
)
723 WALK_SUBEXPR (b
->expr1
);
724 WALK_SUBEXPR (b
->expr2
);
725 WALK_SUBCODE (b
->next
);