In gcc/objc/: 2010-12-29 Nicola Pero <nicola.pero@meta-innovation.com>
[official-gcc.git] / gcc / fortran / frontend-passes.c
blob339458e2d621f22fc1e54ee56ef742ca35b2ae07
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)
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. */
55 static int
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);
61 return 0;
64 /* Callback for each gfc_expr node invoked through gfc_code_walker
65 from optimize_namespace. */
67 static int
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);
73 return 0;
76 /* Optimize a namespace, including all contained namespaces. */
78 static void
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);
87 /* Replace code like
88 a = matmul(b,c) + d
89 with
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.
95 static bool
96 optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
98 gfc_expr *e;
100 e = *rhs;
101 if (e->expr_type == EXPR_OP)
103 switch (e->value.op.op)
105 /* Unary operators and exponentiation: Only look at a single
106 operand. */
107 case INTRINSIC_NOT:
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))
113 return true;
114 break;
116 default:
117 /* Binary operators. */
118 if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
119 return true;
121 if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
122 return true;
124 break;
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)))
139 gfc_code *n;
140 gfc_expr *new_expr;
142 /* Insert a new assignment statement after the current one. */
143 n = XCNEW (gfc_code);
144 n->op = EXEC_ASSIGN;
145 n->loc = c->loc;
146 n->next = c->next;
147 c->next = n;
149 n->expr1 = gfc_copy_expr (c->expr1);
150 n->expr2 = c->expr2;
151 new_expr = gfc_copy_expr (c->expr1);
152 c->expr2 = e;
153 *rhs = new_expr;
155 return true;
159 /* Nothing to optimize. */
160 return false;
163 /* Optimizations for an assignment. */
165 static void
166 optimize_assignment (gfc_code * c)
168 gfc_expr *lhs, *rhs;
170 lhs = c->expr1;
171 rhs = c->expr2;
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);
183 return;
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. */
196 static void
197 strip_function_call (gfc_expr *e)
199 gfc_expr *e1;
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);
207 e1 = a->expr;
209 /* Free the remaining arglist, if any. */
210 if (a->next)
211 gfc_free_actual_arglist (a->next);
213 /* Graft the argument expression onto the original function. */
214 *e = *e1;
215 gfc_free (e1);
219 /* Recursive optimization of operators. */
221 static bool
222 optimize_op (gfc_expr *e)
224 gfc_intrinsic_op op = e->value.op.op;
226 switch (op)
228 case INTRINSIC_EQ:
229 case INTRINSIC_EQ_OS:
230 case INTRINSIC_GE:
231 case INTRINSIC_GE_OS:
232 case INTRINSIC_LE:
233 case INTRINSIC_LE_OS:
234 case INTRINSIC_NE:
235 case INTRINSIC_NE_OS:
236 case INTRINSIC_GT:
237 case INTRINSIC_GT_OS:
238 case INTRINSIC_LT:
239 case INTRINSIC_LT_OS:
240 return optimize_comparison (e, op);
242 default:
243 break;
246 return false;
249 /* Optimize expressions for equality. */
251 static bool
252 optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
254 gfc_expr *op1, *op2;
255 bool change;
256 int eq;
257 bool result;
259 op1 = e->value.op.op1;
260 op2 = e->value.op.op2;
262 /* Strip off unneeded TRIM calls from string comparisons. */
264 change = false;
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);
271 change = true;
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);
279 change = true;
282 if (change)
284 optimize_comparison (e, op);
285 return true;
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. */
292 if (e->rank > 0)
293 return false;
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);
302 if (eq == -2)
304 /* Replace A // B < A // C with B < C, and A // B < C // B
305 with A < C. */
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)
323 return -2;
324 else
326 gfc_free (op1_left);
327 gfc_free (op2_left);
328 e->value.op.op1 = op1_right;
329 e->value.op.op2 = op2_right;
330 optimize_comparison (e, op);
331 return true;
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);
341 return true;
345 else
347 /* eq can only be -1, 0 or 1 at this point. */
348 switch (op)
350 case INTRINSIC_EQ:
351 case INTRINSIC_EQ_OS:
352 result = eq == 0;
353 break;
355 case INTRINSIC_GE:
356 case INTRINSIC_GE_OS:
357 result = eq >= 0;
358 break;
360 case INTRINSIC_LE:
361 case INTRINSIC_LE_OS:
362 result = eq <= 0;
363 break;
365 case INTRINSIC_NE:
366 case INTRINSIC_NE_OS:
367 result = eq != 0;
368 break;
370 case INTRINSIC_GT:
371 case INTRINSIC_GT_OS:
372 result = eq > 0;
373 break;
375 case INTRINSIC_LT:
376 case INTRINSIC_LT_OS:
377 result = eq < 0;
378 break;
380 default:
381 gfc_internal_error ("illegal OP in optimize_comparison");
382 break;
385 /* Replace the expression by a constant expression. The typespec
386 and where remains the way it is. */
387 gfc_free (op1);
388 gfc_free (op2);
389 e->expr_type = EXPR_CONSTANT;
390 e->value.logical = result;
391 return true;
395 return false;
398 #define WALK_SUBEXPR(NODE) \
399 do \
401 result = gfc_expr_walker (&(NODE), exprfn, data); \
402 if (result) \
403 return result; \
405 while (0)
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)
413 while (*e)
415 int walk_subtrees = 1;
416 gfc_actual_arglist *a;
417 gfc_ref *r;
418 gfc_constructor *c;
420 int result = exprfn (e, &walk_subtrees, data);
421 if (result)
422 return result;
423 if (walk_subtrees)
424 switch ((*e)->expr_type)
426 case EXPR_OP:
427 WALK_SUBEXPR ((*e)->value.op.op1);
428 WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
429 break;
430 case EXPR_FUNCTION:
431 for (a = (*e)->value.function.actual; a; a = a->next)
432 WALK_SUBEXPR (a->expr);
433 break;
434 case EXPR_COMPCALL:
435 case EXPR_PPC:
436 WALK_SUBEXPR ((*e)->value.compcall.base_object);
437 for (a = (*e)->value.compcall.actual; a; a = a->next)
438 WALK_SUBEXPR (a->expr);
439 break;
441 case EXPR_STRUCTURE:
442 case EXPR_ARRAY:
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)
457 break;
459 /* Fall through to the variable case in order to walk the
460 the reference. */
462 case EXPR_SUBSTRING:
463 case EXPR_VARIABLE:
464 for (r = (*e)->ref; r; r = r->next)
466 gfc_array_ref *ar;
467 int i;
469 switch (r->type)
471 case REF_ARRAY:
472 ar = &r->u.ar;
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]);
483 break;
485 case REF_SUBSTRING:
486 WALK_SUBEXPR (r->u.ss.start);
487 WALK_SUBEXPR (r->u.ss.end);
488 break;
490 case REF_COMPONENT:
491 break;
495 default:
496 break;
498 return 0;
500 return 0;
503 #define WALK_SUBCODE(NODE) \
504 do \
506 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
507 if (result) \
508 return result; \
510 while (0)
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,
519 void *data)
521 for (; *c; c = &(*c)->next)
523 int walk_subtrees = 1;
524 int result = codefn (c, &walk_subtrees, data);
525 if (result)
526 return result;
528 if (walk_subtrees)
530 gfc_code *b;
531 gfc_actual_arglist *a;
533 switch ((*c)->op)
535 case EXEC_DO:
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);
540 break;
542 case EXEC_CALL:
543 case EXEC_ASSIGN_CALL:
544 for (a = (*c)->ext.actual; a; a = a->next)
545 WALK_SUBEXPR (a->expr);
546 break;
548 case EXEC_CALL_PPC:
549 WALK_SUBEXPR ((*c)->expr1);
550 for (a = (*c)->ext.actual; a; a = a->next)
551 WALK_SUBEXPR (a->expr);
552 break;
554 case EXEC_SELECT:
555 WALK_SUBEXPR ((*c)->expr1);
556 for (b = (*c)->block; b; b = b->block)
558 gfc_case *cp;
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);
566 continue;
568 case EXEC_ALLOCATE:
569 case EXEC_DEALLOCATE:
571 gfc_alloc *a;
572 for (a = (*c)->ext.alloc.list; a; a = a->next)
573 WALK_SUBEXPR (a->expr);
574 break;
577 case EXEC_FORALL:
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);
587 break;
590 case EXEC_OPEN:
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);
612 break;
614 case EXEC_CLOSE:
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);
619 break;
621 case EXEC_BACKSPACE:
622 case EXEC_ENDFILE:
623 case EXEC_REWIND:
624 case EXEC_FLUSH:
625 WALK_SUBEXPR ((*c)->ext.filepos->unit);
626 WALK_SUBEXPR ((*c)->ext.filepos->iostat);
627 WALK_SUBEXPR ((*c)->ext.filepos->iomsg);
628 break;
630 case EXEC_INQUIRE:
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);
667 break;
669 case EXEC_WAIT:
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);
674 break;
676 case EXEC_READ:
677 case EXEC_WRITE:
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);
695 break;
697 case EXEC_OMP_DO:
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:
706 case EXEC_OMP_TASK:
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);
713 break;
714 default:
715 break;
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);
729 return 0;