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
)
45 optimize_namespace (ns
);
48 /* Callback for each gfc_code node invoked through gfc_code_walker
49 from optimize_namespace. */
52 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
53 void *data ATTRIBUTE_UNUSED
)
55 if ((*c
)->op
== EXEC_ASSIGN
)
56 optimize_assignment (*c
);
60 /* Callback for each gfc_expr node invoked through gfc_code_walker
61 from optimize_namespace. */
64 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
65 void *data ATTRIBUTE_UNUSED
)
67 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
68 gfc_simplify_expr (*e
, 0);
72 /* Optimize a namespace, including all contained namespaces. */
75 optimize_namespace (gfc_namespace
*ns
)
77 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
79 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
80 optimize_namespace (ns
);
86 a = matmul(b,c) ; a = a + d
87 where the array function is not elemental and not allocatable
88 and does not depend on the left-hand side.
92 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
97 if (e
->expr_type
== EXPR_OP
)
99 switch (e
->value
.op
.op
)
101 /* Unary operators and exponentiation: Only look at a single
104 case INTRINSIC_UPLUS
:
105 case INTRINSIC_UMINUS
:
106 case INTRINSIC_PARENTHESES
:
107 case INTRINSIC_POWER
:
108 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
113 /* Binary operators. */
114 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
117 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
123 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
124 && ! (e
->value
.function
.esym
125 && (e
->value
.function
.esym
->attr
.elemental
126 || e
->value
.function
.esym
->attr
.allocatable
127 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
128 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
129 && ! (e
->value
.function
.isym
130 && (e
->value
.function
.isym
->elemental
131 || e
->ts
.type
!= c
->expr1
->ts
.type
132 || e
->ts
.kind
!= c
->expr1
->ts
.kind
)))
138 /* Insert a new assignment statement after the current one. */
139 n
= XCNEW (gfc_code
);
145 n
->expr1
= gfc_copy_expr (c
->expr1
);
147 new_expr
= gfc_copy_expr (c
->expr1
);
155 /* Nothing to optimize. */
159 /* Optimizations for an assignment. */
162 optimize_assignment (gfc_code
* c
)
169 /* Optimize away a = trim(b), where a is a character variable. */
171 if (lhs
->ts
.type
== BT_CHARACTER
)
173 if (rhs
->expr_type
== EXPR_FUNCTION
&&
174 rhs
->value
.function
.isym
&&
175 rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
177 strip_function_call (rhs
);
178 optimize_assignment (c
);
183 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
184 optimize_binop_array_assignment (c
, &rhs
, false);
188 /* Remove an unneeded function call, modifying the expression.
189 This replaces the function call with the value of its
190 first argument. The rest of the argument list is freed. */
193 strip_function_call (gfc_expr
*e
)
196 gfc_actual_arglist
*a
;
198 a
= e
->value
.function
.actual
;
200 /* We should have at least one argument. */
201 gcc_assert (a
->expr
!= NULL
);
205 /* Free the remaining arglist, if any. */
207 gfc_free_actual_arglist (a
->next
);
209 /* Graft the argument expression onto the original function. */
215 /* Recursive optimization of operators. */
218 optimize_op (gfc_expr
*e
)
220 gfc_intrinsic_op op
= e
->value
.op
.op
;
225 case INTRINSIC_EQ_OS
:
227 case INTRINSIC_GE_OS
:
229 case INTRINSIC_LE_OS
:
231 case INTRINSIC_NE_OS
:
233 case INTRINSIC_GT_OS
:
235 case INTRINSIC_LT_OS
:
236 return optimize_comparison (e
, op
);
245 /* Optimize expressions for equality. */
248 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
255 op1
= e
->value
.op
.op1
;
256 op2
= e
->value
.op
.op2
;
258 /* Strip off unneeded TRIM calls from string comparisons. */
262 if (op1
->expr_type
== EXPR_FUNCTION
263 && op1
->value
.function
.isym
264 && op1
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
266 strip_function_call (op1
);
270 if (op2
->expr_type
== EXPR_FUNCTION
271 && op2
->value
.function
.isym
272 && op2
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
274 strip_function_call (op2
);
280 optimize_comparison (e
, op
);
284 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
285 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
286 handles them well). However, there are also cases that need a non-scalar
287 argument. For example the any intrinsic. See PR 45380. */
291 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
293 if (flag_finite_math_only
294 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
295 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
297 eq
= gfc_dep_compare_expr (op1
, op2
);
300 /* Replace A // B < A // C with B < C, and A // B < C // B
302 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
303 && op1
->value
.op
.op
== INTRINSIC_CONCAT
304 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
306 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
307 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
308 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
309 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
311 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
313 /* Watch out for 'A ' // x vs. 'A' // x. */
315 if (op1_left
->expr_type
== EXPR_CONSTANT
316 && op2_left
->expr_type
== EXPR_CONSTANT
317 && op1_left
->value
.character
.length
318 != op2_left
->value
.character
.length
)
324 e
->value
.op
.op1
= op1_right
;
325 e
->value
.op
.op2
= op2_right
;
326 optimize_comparison (e
, op
);
330 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
332 gfc_free (op1_right
);
333 gfc_free (op2_right
);
334 e
->value
.op
.op1
= op1_left
;
335 e
->value
.op
.op2
= op2_left
;
336 optimize_comparison (e
, op
);
343 /* eq can only be -1, 0 or 1 at this point. */
347 case INTRINSIC_EQ_OS
:
352 case INTRINSIC_GE_OS
:
357 case INTRINSIC_LE_OS
:
362 case INTRINSIC_NE_OS
:
367 case INTRINSIC_GT_OS
:
372 case INTRINSIC_LT_OS
:
377 gfc_internal_error ("illegal OP in optimize_comparison");
381 /* Replace the expression by a constant expression. The typespec
382 and where remains the way it is. */
385 e
->expr_type
= EXPR_CONSTANT
;
386 e
->value
.logical
= result
;
394 #define WALK_SUBEXPR(NODE) \
397 result = gfc_expr_walker (&(NODE), exprfn, data); \
402 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
404 /* Walk expression *E, calling EXPRFN on each expression in it. */
407 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
411 int walk_subtrees
= 1;
412 gfc_actual_arglist
*a
;
416 int result
= exprfn (e
, &walk_subtrees
, data
);
420 switch ((*e
)->expr_type
)
423 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
424 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
427 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
428 WALK_SUBEXPR (a
->expr
);
432 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
433 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
434 WALK_SUBEXPR (a
->expr
);
439 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
440 c
= gfc_constructor_next (c
))
442 WALK_SUBEXPR (c
->expr
);
443 if (c
->iterator
!= NULL
)
445 WALK_SUBEXPR (c
->iterator
->var
);
446 WALK_SUBEXPR (c
->iterator
->start
);
447 WALK_SUBEXPR (c
->iterator
->end
);
448 WALK_SUBEXPR (c
->iterator
->step
);
452 if ((*e
)->expr_type
!= EXPR_ARRAY
)
455 /* Fall through to the variable case in order to walk the
460 for (r
= (*e
)->ref
; r
; r
= r
->next
)
469 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
471 for (i
=0; i
< ar
->dimen
; i
++)
473 WALK_SUBEXPR (ar
->start
[i
]);
474 WALK_SUBEXPR (ar
->end
[i
]);
475 WALK_SUBEXPR (ar
->stride
[i
]);
482 WALK_SUBEXPR (r
->u
.ss
.start
);
483 WALK_SUBEXPR (r
->u
.ss
.end
);
499 #define WALK_SUBCODE(NODE) \
502 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
508 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
509 on each expression in it. If any of the hooks returns non-zero, that
510 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
511 no subcodes or subexpressions are traversed. */
514 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
517 for (; *c
; c
= &(*c
)->next
)
519 int walk_subtrees
= 1;
520 int result
= codefn (c
, &walk_subtrees
, data
);
529 WALK_SUBEXPR ((*c
)->ext
.iterator
->var
);
530 WALK_SUBEXPR ((*c
)->ext
.iterator
->start
);
531 WALK_SUBEXPR ((*c
)->ext
.iterator
->end
);
532 WALK_SUBEXPR ((*c
)->ext
.iterator
->step
);
535 WALK_SUBEXPR ((*c
)->expr1
);
536 for (b
= (*c
)->block
; b
; b
= b
->block
)
539 for (cp
= b
->ext
.case_list
; cp
; cp
= cp
->next
)
541 WALK_SUBEXPR (cp
->low
);
542 WALK_SUBEXPR (cp
->high
);
544 WALK_SUBCODE (b
->next
);
548 case EXEC_DEALLOCATE
:
551 for (a
= (*c
)->ext
.alloc
.list
; a
; a
= a
->next
)
552 WALK_SUBEXPR (a
->expr
);
557 gfc_forall_iterator
*fa
;
558 for (fa
= (*c
)->ext
.forall_iterator
; fa
; fa
= fa
->next
)
560 WALK_SUBEXPR (fa
->var
);
561 WALK_SUBEXPR (fa
->start
);
562 WALK_SUBEXPR (fa
->end
);
563 WALK_SUBEXPR (fa
->stride
);
568 WALK_SUBEXPR ((*c
)->ext
.open
->unit
);
569 WALK_SUBEXPR ((*c
)->ext
.open
->file
);
570 WALK_SUBEXPR ((*c
)->ext
.open
->status
);
571 WALK_SUBEXPR ((*c
)->ext
.open
->access
);
572 WALK_SUBEXPR ((*c
)->ext
.open
->form
);
573 WALK_SUBEXPR ((*c
)->ext
.open
->recl
);
574 WALK_SUBEXPR ((*c
)->ext
.open
->blank
);
575 WALK_SUBEXPR ((*c
)->ext
.open
->position
);
576 WALK_SUBEXPR ((*c
)->ext
.open
->action
);
577 WALK_SUBEXPR ((*c
)->ext
.open
->delim
);
578 WALK_SUBEXPR ((*c
)->ext
.open
->pad
);
579 WALK_SUBEXPR ((*c
)->ext
.open
->iostat
);
580 WALK_SUBEXPR ((*c
)->ext
.open
->iomsg
);
581 WALK_SUBEXPR ((*c
)->ext
.open
->convert
);
582 WALK_SUBEXPR ((*c
)->ext
.open
->decimal
);
583 WALK_SUBEXPR ((*c
)->ext
.open
->encoding
);
584 WALK_SUBEXPR ((*c
)->ext
.open
->round
);
585 WALK_SUBEXPR ((*c
)->ext
.open
->sign
);
586 WALK_SUBEXPR ((*c
)->ext
.open
->asynchronous
);
587 WALK_SUBEXPR ((*c
)->ext
.open
->id
);
588 WALK_SUBEXPR ((*c
)->ext
.open
->newunit
);
591 WALK_SUBEXPR ((*c
)->ext
.close
->unit
);
592 WALK_SUBEXPR ((*c
)->ext
.close
->status
);
593 WALK_SUBEXPR ((*c
)->ext
.close
->iostat
);
594 WALK_SUBEXPR ((*c
)->ext
.close
->iomsg
);
600 WALK_SUBEXPR ((*c
)->ext
.filepos
->unit
);
601 WALK_SUBEXPR ((*c
)->ext
.filepos
->iostat
);
602 WALK_SUBEXPR ((*c
)->ext
.filepos
->iomsg
);
605 WALK_SUBEXPR ((*c
)->ext
.inquire
->unit
);
606 WALK_SUBEXPR ((*c
)->ext
.inquire
->file
);
607 WALK_SUBEXPR ((*c
)->ext
.inquire
->iomsg
);
608 WALK_SUBEXPR ((*c
)->ext
.inquire
->iostat
);
609 WALK_SUBEXPR ((*c
)->ext
.inquire
->exist
);
610 WALK_SUBEXPR ((*c
)->ext
.inquire
->opened
);
611 WALK_SUBEXPR ((*c
)->ext
.inquire
->number
);
612 WALK_SUBEXPR ((*c
)->ext
.inquire
->named
);
613 WALK_SUBEXPR ((*c
)->ext
.inquire
->name
);
614 WALK_SUBEXPR ((*c
)->ext
.inquire
->access
);
615 WALK_SUBEXPR ((*c
)->ext
.inquire
->sequential
);
616 WALK_SUBEXPR ((*c
)->ext
.inquire
->direct
);
617 WALK_SUBEXPR ((*c
)->ext
.inquire
->form
);
618 WALK_SUBEXPR ((*c
)->ext
.inquire
->formatted
);
619 WALK_SUBEXPR ((*c
)->ext
.inquire
->unformatted
);
620 WALK_SUBEXPR ((*c
)->ext
.inquire
->recl
);
621 WALK_SUBEXPR ((*c
)->ext
.inquire
->nextrec
);
622 WALK_SUBEXPR ((*c
)->ext
.inquire
->blank
);
623 WALK_SUBEXPR ((*c
)->ext
.inquire
->position
);
624 WALK_SUBEXPR ((*c
)->ext
.inquire
->action
);
625 WALK_SUBEXPR ((*c
)->ext
.inquire
->read
);
626 WALK_SUBEXPR ((*c
)->ext
.inquire
->write
);
627 WALK_SUBEXPR ((*c
)->ext
.inquire
->readwrite
);
628 WALK_SUBEXPR ((*c
)->ext
.inquire
->delim
);
629 WALK_SUBEXPR ((*c
)->ext
.inquire
->encoding
);
630 WALK_SUBEXPR ((*c
)->ext
.inquire
->pad
);
631 WALK_SUBEXPR ((*c
)->ext
.inquire
->iolength
);
632 WALK_SUBEXPR ((*c
)->ext
.inquire
->convert
);
633 WALK_SUBEXPR ((*c
)->ext
.inquire
->strm_pos
);
634 WALK_SUBEXPR ((*c
)->ext
.inquire
->asynchronous
);
635 WALK_SUBEXPR ((*c
)->ext
.inquire
->decimal
);
636 WALK_SUBEXPR ((*c
)->ext
.inquire
->pending
);
637 WALK_SUBEXPR ((*c
)->ext
.inquire
->id
);
638 WALK_SUBEXPR ((*c
)->ext
.inquire
->sign
);
639 WALK_SUBEXPR ((*c
)->ext
.inquire
->size
);
640 WALK_SUBEXPR ((*c
)->ext
.inquire
->round
);
643 WALK_SUBEXPR ((*c
)->ext
.wait
->unit
);
644 WALK_SUBEXPR ((*c
)->ext
.wait
->iostat
);
645 WALK_SUBEXPR ((*c
)->ext
.wait
->iomsg
);
646 WALK_SUBEXPR ((*c
)->ext
.wait
->id
);
650 WALK_SUBEXPR ((*c
)->ext
.dt
->io_unit
);
651 WALK_SUBEXPR ((*c
)->ext
.dt
->format_expr
);
652 WALK_SUBEXPR ((*c
)->ext
.dt
->rec
);
653 WALK_SUBEXPR ((*c
)->ext
.dt
->advance
);
654 WALK_SUBEXPR ((*c
)->ext
.dt
->iostat
);
655 WALK_SUBEXPR ((*c
)->ext
.dt
->size
);
656 WALK_SUBEXPR ((*c
)->ext
.dt
->iomsg
);
657 WALK_SUBEXPR ((*c
)->ext
.dt
->id
);
658 WALK_SUBEXPR ((*c
)->ext
.dt
->pos
);
659 WALK_SUBEXPR ((*c
)->ext
.dt
->asynchronous
);
660 WALK_SUBEXPR ((*c
)->ext
.dt
->blank
);
661 WALK_SUBEXPR ((*c
)->ext
.dt
->decimal
);
662 WALK_SUBEXPR ((*c
)->ext
.dt
->delim
);
663 WALK_SUBEXPR ((*c
)->ext
.dt
->pad
);
664 WALK_SUBEXPR ((*c
)->ext
.dt
->round
);
665 WALK_SUBEXPR ((*c
)->ext
.dt
->sign
);
666 WALK_SUBEXPR ((*c
)->ext
.dt
->extra_comma
);
669 case EXEC_OMP_PARALLEL
:
670 case EXEC_OMP_PARALLEL_DO
:
671 case EXEC_OMP_PARALLEL_SECTIONS
:
672 case EXEC_OMP_PARALLEL_WORKSHARE
:
673 case EXEC_OMP_SECTIONS
:
674 case EXEC_OMP_SINGLE
:
675 case EXEC_OMP_WORKSHARE
:
676 case EXEC_OMP_END_SINGLE
:
678 if ((*c
)->ext
.omp_clauses
)
680 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->if_expr
);
681 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->num_threads
);
682 WALK_SUBEXPR ((*c
)->ext
.omp_clauses
->chunk_size
);
688 WALK_SUBEXPR ((*c
)->expr1
);
689 WALK_SUBEXPR ((*c
)->expr2
);
690 WALK_SUBEXPR ((*c
)->expr3
);
691 for (b
= (*c
)->block
; b
; b
= b
->block
)
693 WALK_SUBEXPR (b
->expr1
);
694 WALK_SUBEXPR (b
->expr2
);
695 WALK_SUBCODE (b
->next
);