2010-10-20 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[official-gcc.git] / gcc / fortran / frontend-passes.c
blobc08930297e16505ee65d0f762acb7f0385ec6ac8
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
10 version.
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
15 for more details.
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/>. */
21 #include "config.h"
22 #include "system.h"
23 #include "gfortran.h"
24 #include "arith.h"
25 #include "flags.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "opts.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. */
41 void
42 gfc_run_passes (gfc_namespace *ns)
44 if (optimize)
45 optimize_namespace (ns);
48 /* Callback for each gfc_code node invoked through gfc_code_walker
49 from optimize_namespace. */
51 static int
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);
57 return 0;
60 /* Callback for each gfc_expr node invoked through gfc_code_walker
61 from optimize_namespace. */
63 static int
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);
69 return 0;
72 /* Optimize a namespace, including all contained namespaces. */
74 static void
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);
83 /* Replace code like
84 a = matmul(b,c) + d
85 with
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.
91 static bool
92 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
94 gfc_expr *e;
96 e = *rhs;
97 if (e->expr_type == EXPR_OP)
99 switch (e->value.op.op)
101 /* Unary operators and exponentiation: Only look at a single
102 operand. */
103 case INTRINSIC_NOT:
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))
109 return true;
110 break;
112 default:
113 /* Binary operators. */
114 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
115 return true;
117 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
118 return true;
120 break;
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)))
135 gfc_code *n;
136 gfc_expr *new_expr;
138 /* Insert a new assignment statement after the current one. */
139 n = XCNEW (gfc_code);
140 n->op = EXEC_ASSIGN;
141 n->loc = c->loc;
142 n->next = c->next;
143 c->next = n;
145 n->expr1 = gfc_copy_expr (c->expr1);
146 n->expr2 = c->expr2;
147 new_expr = gfc_copy_expr (c->expr1);
148 c->expr2 = e;
149 *rhs = new_expr;
151 return true;
155 /* Nothing to optimize. */
156 return false;
159 /* Optimizations for an assignment. */
161 static void
162 optimize_assignment (gfc_code * c)
164 gfc_expr *lhs, *rhs;
166 lhs = c->expr1;
167 rhs = c->expr2;
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);
179 return;
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. */
192 static void
193 strip_function_call (gfc_expr *e)
195 gfc_expr *e1;
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);
203 e1 = a->expr;
205 /* Free the remaining arglist, if any. */
206 if (a->next)
207 gfc_free_actual_arglist (a->next);
209 /* Graft the argument expression onto the original function. */
210 *e = *e1;
211 gfc_free (e1);
215 /* Recursive optimization of operators. */
217 static bool
218 optimize_op (gfc_expr *e)
220 gfc_intrinsic_op op = e->value.op.op;
222 switch (op)
224 case INTRINSIC_EQ:
225 case INTRINSIC_EQ_OS:
226 case INTRINSIC_GE:
227 case INTRINSIC_GE_OS:
228 case INTRINSIC_LE:
229 case INTRINSIC_LE_OS:
230 case INTRINSIC_NE:
231 case INTRINSIC_NE_OS:
232 case INTRINSIC_GT:
233 case INTRINSIC_GT_OS:
234 case INTRINSIC_LT:
235 case INTRINSIC_LT_OS:
236 return optimize_comparison (e, op);
238 default:
239 break;
242 return false;
245 /* Optimize expressions for equality. */
247 static bool
248 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
250 gfc_expr *op1, *op2;
251 bool change;
252 int eq;
253 bool result;
255 op1 = e->value.op.op1;
256 op2 = e->value.op.op2;
258 /* Strip off unneeded TRIM calls from string comparisons. */
260 change = false;
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);
267 change = true;
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);
275 change = true;
278 if (change)
280 optimize_comparison (e, op);
281 return true;
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. */
288 if (e->rank > 0)
289 return false;
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);
298 if (eq == -2)
300 /* Replace A // B < A // C with B < C, and A // B < C // B
301 with A < C. */
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)
319 return -2;
320 else
322 gfc_free (op1_left);
323 gfc_free (op2_left);
324 e->value.op.op1 = op1_right;
325 e->value.op.op2 = op2_right;
326 optimize_comparison (e, op);
327 return true;
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);
337 return true;
341 else
343 /* eq can only be -1, 0 or 1 at this point. */
344 switch (op)
346 case INTRINSIC_EQ:
347 case INTRINSIC_EQ_OS:
348 result = eq == 0;
349 break;
351 case INTRINSIC_GE:
352 case INTRINSIC_GE_OS:
353 result = eq >= 0;
354 break;
356 case INTRINSIC_LE:
357 case INTRINSIC_LE_OS:
358 result = eq <= 0;
359 break;
361 case INTRINSIC_NE:
362 case INTRINSIC_NE_OS:
363 result = eq != 0;
364 break;
366 case INTRINSIC_GT:
367 case INTRINSIC_GT_OS:
368 result = eq > 0;
369 break;
371 case INTRINSIC_LT:
372 case INTRINSIC_LT_OS:
373 result = eq < 0;
374 break;
376 default:
377 gfc_internal_error ("illegal OP in optimize_comparison");
378 break;
381 /* Replace the expression by a constant expression. The typespec
382 and where remains the way it is. */
383 gfc_free (op1);
384 gfc_free (op2);
385 e->expr_type = EXPR_CONSTANT;
386 e->value.logical = result;
387 return true;
391 return false;
394 #define WALK_SUBEXPR(NODE) \
395 do \
397 result = gfc_expr_walker (&(NODE), exprfn, data); \
398 if (result) \
399 return result; \
401 while (0)
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)
409 while (*e)
411 int walk_subtrees = 1;
412 gfc_actual_arglist *a;
413 gfc_ref *r;
414 gfc_constructor *c;
416 int result = exprfn (e, &walk_subtrees, data);
417 if (result)
418 return result;
419 if (walk_subtrees)
420 switch ((*e)->expr_type)
422 case EXPR_OP:
423 WALK_SUBEXPR ((*e)->value.op.op1);
424 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
425 break;
426 case EXPR_FUNCTION:
427 for (a = (*e)->value.function.actual; a; a = a->next)
428 WALK_SUBEXPR (a->expr);
429 break;
430 case EXPR_COMPCALL:
431 case EXPR_PPC:
432 WALK_SUBEXPR ((*e)->value.compcall.base_object);
433 for (a = (*e)->value.compcall.actual; a; a = a->next)
434 WALK_SUBEXPR (a->expr);
435 break;
437 case EXPR_STRUCTURE:
438 case EXPR_ARRAY:
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)
453 break;
455 /* Fall through to the variable case in order to walk the
456 the reference. */
458 case EXPR_SUBSTRING:
459 case EXPR_VARIABLE:
460 for (r = (*e)->ref; r; r = r->next)
462 gfc_array_ref *ar;
463 int i;
465 switch (r->type)
467 case REF_ARRAY:
468 ar = &r->u.ar;
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]);
479 break;
481 case REF_SUBSTRING:
482 WALK_SUBEXPR (r->u.ss.start);
483 WALK_SUBEXPR (r->u.ss.end);
484 break;
486 case REF_COMPONENT:
487 break;
491 default:
492 break;
494 return 0;
496 return 0;
499 #define WALK_SUBCODE(NODE) \
500 do \
502 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
503 if (result) \
504 return result; \
506 while (0)
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,
515 void *data)
517 for (; *c; c = &(*c)->next)
519 int walk_subtrees = 1;
520 int result = codefn (c, &walk_subtrees, data);
521 if (result)
522 return result;
523 if (walk_subtrees)
525 gfc_code *b;
526 switch ((*c)->op)
528 case EXEC_DO:
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);
533 break;
534 case EXEC_SELECT:
535 WALK_SUBEXPR ((*c)->expr1);
536 for (b = (*c)->block; b; b = b->block)
538 gfc_case *cp;
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);
546 continue;
547 case EXEC_ALLOCATE:
548 case EXEC_DEALLOCATE:
550 gfc_alloc *a;
551 for (a = (*c)->ext.alloc.list; a; a = a->next)
552 WALK_SUBEXPR (a->expr);
553 break;
555 case EXEC_FORALL:
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);
565 break;
567 case EXEC_OPEN:
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);
589 break;
590 case EXEC_CLOSE:
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);
595 break;
596 case EXEC_BACKSPACE:
597 case EXEC_ENDFILE:
598 case EXEC_REWIND:
599 case EXEC_FLUSH:
600 WALK_SUBEXPR ((*c)->ext.filepos->unit);
601 WALK_SUBEXPR ((*c)->ext.filepos->iostat);
602 WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
603 break;
604 case EXEC_INQUIRE:
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);
641 break;
642 case EXEC_WAIT:
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);
647 break;
648 case EXEC_READ:
649 case EXEC_WRITE:
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);
667 break;
668 case EXEC_OMP_DO:
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:
677 case EXEC_OMP_TASK:
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);
684 break;
685 default:
686 break;
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);
699 return 0;