1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2014 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/>. */
23 #include "coretypes.h"
27 #include "dependency.h"
28 #include "constructor.h"
31 /* Forward declarations. */
33 static void strip_function_call (gfc_expr
*);
34 static void optimize_namespace (gfc_namespace
*);
35 static void optimize_assignment (gfc_code
*);
36 static bool optimize_op (gfc_expr
*);
37 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
38 static bool optimize_trim (gfc_expr
*);
39 static bool optimize_lexical_comparison (gfc_expr
*);
40 static void optimize_minmaxloc (gfc_expr
**);
41 static bool is_empty_string (gfc_expr
*e
);
42 static void doloop_warn (gfc_namespace
*);
43 static void optimize_reduction (gfc_namespace
*);
44 static int callback_reduction (gfc_expr
**, int *, void *);
46 /* How deep we are inside an argument list. */
48 static int count_arglist
;
50 /* Vector of gfc_expr ** we operate on. */
52 static vec
<gfc_expr
**> expr_array
;
54 /* Pointer to the gfc_code we currently work on - to be able to insert
55 a block before the statement. */
57 static gfc_code
**current_code
;
59 /* Pointer to the block to be inserted, and the statement we are
60 changing within the block. */
62 static gfc_code
*inserted_block
, **changed_statement
;
64 /* The namespace we are currently dealing with. */
66 static gfc_namespace
*current_ns
;
68 /* If we are within any forall loop. */
70 static int forall_level
;
72 /* Keep track of whether we are within an OMP workshare. */
74 static bool in_omp_workshare
;
76 /* Keep track of iterators for array constructors. */
78 static int iterator_level
;
80 /* Keep track of DO loop levels. */
82 static vec
<gfc_code
*> doloop_list
;
84 static int doloop_level
;
86 /* Vector of gfc_expr * to keep track of DO loops. */
88 struct my_struct
*evec
;
90 /* Keep track of association lists. */
92 static bool in_assoc_list
;
94 /* Entry point - run all passes for a namespace. */
97 gfc_run_passes (gfc_namespace
*ns
)
100 /* Warn about dubious DO loops where the index might
105 doloop_list
.release ();
107 if (gfc_option
.flag_frontend_optimize
)
109 optimize_namespace (ns
);
110 optimize_reduction (ns
);
111 if (gfc_option
.dump_fortran_optimized
)
112 gfc_dump_parse_tree (ns
, stdout
);
114 expr_array
.release ();
118 /* Callback for each gfc_code node invoked through gfc_code_walker
119 from optimize_namespace. */
122 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
123 void *data ATTRIBUTE_UNUSED
)
130 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
131 || op
== EXEC_CALL_PPC
)
137 inserted_block
= NULL
;
138 changed_statement
= NULL
;
140 if (op
== EXEC_ASSIGN
)
141 optimize_assignment (*c
);
145 /* Callback for each gfc_expr node invoked through gfc_code_walker
146 from optimize_namespace. */
149 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
150 void *data ATTRIBUTE_UNUSED
)
154 if ((*e
)->expr_type
== EXPR_FUNCTION
)
157 function_expr
= true;
160 function_expr
= false;
162 if (optimize_trim (*e
))
163 gfc_simplify_expr (*e
, 0);
165 if (optimize_lexical_comparison (*e
))
166 gfc_simplify_expr (*e
, 0);
168 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
169 gfc_simplify_expr (*e
, 0);
171 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
172 switch ((*e
)->value
.function
.isym
->id
)
174 case GFC_ISYM_MINLOC
:
175 case GFC_ISYM_MAXLOC
:
176 optimize_minmaxloc (e
);
188 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
189 function is a scalar, just copy it; otherwise returns the new element, the
190 old one can be freed. */
193 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
195 gfc_expr
*fcn
, *e
= c
->expr
;
197 fcn
= gfc_copy_expr (e
);
200 gfc_constructor_base newbase
;
202 gfc_constructor
*new_c
;
205 new_expr
= gfc_get_expr ();
206 new_expr
->expr_type
= EXPR_ARRAY
;
207 new_expr
->ts
= e
->ts
;
208 new_expr
->where
= e
->where
;
210 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
211 new_c
->iterator
= c
->iterator
;
212 new_expr
->value
.constructor
= newbase
;
220 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
222 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
223 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
224 fn
->value
.function
.isym
->name
,
225 fn
->where
, 3, fcn
, NULL
, NULL
);
226 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
227 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
228 fn
->value
.function
.isym
->name
,
229 fn
->where
, 2, fcn
, NULL
);
231 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
233 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
239 /* Callback function for optimzation of reductions to scalars. Transform ANY
240 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
241 correspondingly. Handly only the simple cases without MASK and DIM. */
244 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
245 void *data ATTRIBUTE_UNUSED
)
250 gfc_actual_arglist
*a
;
251 gfc_actual_arglist
*dim
;
253 gfc_expr
*res
, *new_expr
;
254 gfc_actual_arglist
*mask
;
258 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
259 || fn
->value
.function
.isym
== NULL
)
262 id
= fn
->value
.function
.isym
->id
;
264 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
265 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
268 a
= fn
->value
.function
.actual
;
270 /* Don't handle MASK or DIM. */
274 if (dim
->expr
!= NULL
)
277 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
280 if ( mask
->expr
!= NULL
)
286 if (arg
->expr_type
!= EXPR_ARRAY
)
295 case GFC_ISYM_PRODUCT
:
296 op
= INTRINSIC_TIMES
;
311 c
= gfc_constructor_first (arg
->value
.constructor
);
313 /* Don't do any simplififcation if we have
314 - no element in the constructor or
315 - only have a single element in the array which contains an
321 res
= copy_walk_reduction_arg (c
, fn
);
323 c
= gfc_constructor_next (c
);
326 new_expr
= gfc_get_expr ();
327 new_expr
->ts
= fn
->ts
;
328 new_expr
->expr_type
= EXPR_OP
;
329 new_expr
->rank
= fn
->rank
;
330 new_expr
->where
= fn
->where
;
331 new_expr
->value
.op
.op
= op
;
332 new_expr
->value
.op
.op1
= res
;
333 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
335 c
= gfc_constructor_next (c
);
338 gfc_simplify_expr (res
, 0);
345 /* Callback function for common function elimination, called from cfe_expr_0.
346 Put all eligible function expressions into expr_array. */
349 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
350 void *data ATTRIBUTE_UNUSED
)
353 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
356 /* We don't do character functions with unknown charlens. */
357 if ((*e
)->ts
.type
== BT_CHARACTER
358 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
359 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
362 /* We don't do function elimination within FORALL statements, it can
363 lead to wrong-code in certain circumstances. */
365 if (forall_level
> 0)
368 /* Function elimination inside an iterator could lead to functions which
369 depend on iterator variables being moved outside. FIXME: We should check
370 if the functions do indeed depend on the iterator variable. */
372 if (iterator_level
> 0)
375 /* If we don't know the shape at compile time, we create an allocatable
376 temporary variable to hold the intermediate result, but only if
377 allocation on assignment is active. */
379 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !gfc_option
.flag_realloc_lhs
)
382 /* Skip the test for pure functions if -faggressive-function-elimination
384 if ((*e
)->value
.function
.esym
)
386 /* Don't create an array temporary for elemental functions. */
387 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
390 /* Only eliminate potentially impure functions if the
391 user specifically requested it. */
392 if (!gfc_option
.flag_aggressive_function_elimination
393 && !(*e
)->value
.function
.esym
->attr
.pure
394 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
398 if ((*e
)->value
.function
.isym
)
400 /* Conversions are handled on the fly by the middle end,
401 transpose during trans-* stages and TRANSFER by the middle end. */
402 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
403 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
404 || gfc_inline_intrinsic_function_p (*e
))
407 /* Don't create an array temporary for elemental functions,
408 as this would be wasteful of memory.
409 FIXME: Create a scalar temporary during scalarization. */
410 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
413 if (!(*e
)->value
.function
.isym
->pure
)
417 expr_array
.safe_push (e
);
421 /* Auxiliary function to check if an expression is a temporary created by
425 is_fe_temp (gfc_expr
*e
)
427 if (e
->expr_type
!= EXPR_VARIABLE
)
430 return e
->symtree
->n
.sym
->attr
.fe_temp
;
434 /* Returns a new expression (a variable) to be used in place of the old one,
435 with an assignment statement before the current statement to set
436 the value of the variable. Creates a new BLOCK for the statement if
437 that hasn't already been done and puts the statement, plus the
438 newly created variables, in that block. Special cases: If the
439 expression is constant or a temporary which has already
440 been created, just copy it. */
443 create_var (gfc_expr
* e
)
445 char name
[GFC_MAX_SYMBOL_LEN
+1];
447 gfc_symtree
*symtree
;
454 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
455 return gfc_copy_expr (e
);
457 /* If the block hasn't already been created, do so. */
458 if (inserted_block
== NULL
)
460 inserted_block
= XCNEW (gfc_code
);
461 inserted_block
->op
= EXEC_BLOCK
;
462 inserted_block
->loc
= (*current_code
)->loc
;
463 ns
= gfc_build_block_ns (current_ns
);
464 inserted_block
->ext
.block
.ns
= ns
;
465 inserted_block
->ext
.block
.assoc
= NULL
;
467 ns
->code
= *current_code
;
469 /* If the statement has a label, make sure it is transferred to
470 the newly created block. */
472 if ((*current_code
)->here
)
474 inserted_block
->here
= (*current_code
)->here
;
475 (*current_code
)->here
= NULL
;
478 inserted_block
->next
= (*current_code
)->next
;
479 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
480 (*current_code
)->next
= NULL
;
481 /* Insert the BLOCK at the right position. */
482 *current_code
= inserted_block
;
483 ns
->parent
= current_ns
;
486 ns
= inserted_block
->ext
.block
.ns
;
488 sprintf(name
, "__var_%d",num
++);
489 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
492 symbol
= symtree
->n
.sym
;
497 symbol
->as
= gfc_get_array_spec ();
498 symbol
->as
->rank
= e
->rank
;
500 if (e
->shape
== NULL
)
502 /* We don't know the shape at compile time, so we use an
504 symbol
->as
->type
= AS_DEFERRED
;
505 symbol
->attr
.allocatable
= 1;
509 symbol
->as
->type
= AS_EXPLICIT
;
510 /* Copy the shape. */
511 for (i
=0; i
<e
->rank
; i
++)
515 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
517 mpz_set_si (p
->value
.integer
, 1);
518 symbol
->as
->lower
[i
] = p
;
520 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
522 mpz_set (q
->value
.integer
, e
->shape
[i
]);
523 symbol
->as
->upper
[i
] = q
;
528 symbol
->attr
.flavor
= FL_VARIABLE
;
529 symbol
->attr
.referenced
= 1;
530 symbol
->attr
.dimension
= e
->rank
> 0;
531 symbol
->attr
.fe_temp
= 1;
532 gfc_commit_symbol (symbol
);
534 result
= gfc_get_expr ();
535 result
->expr_type
= EXPR_VARIABLE
;
537 result
->rank
= e
->rank
;
538 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
539 result
->symtree
= symtree
;
540 result
->where
= e
->where
;
543 result
->ref
= gfc_get_ref ();
544 result
->ref
->type
= REF_ARRAY
;
545 result
->ref
->u
.ar
.type
= AR_FULL
;
546 result
->ref
->u
.ar
.where
= e
->where
;
547 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
548 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
549 if (warn_array_temporaries
)
550 gfc_warning ("Creating array temporary at %L", &(e
->where
));
553 /* Generate the new assignment. */
554 n
= XCNEW (gfc_code
);
556 n
->loc
= (*current_code
)->loc
;
557 n
->next
= *changed_statement
;
558 n
->expr1
= gfc_copy_expr (result
);
560 *changed_statement
= n
;
565 /* Warn about function elimination. */
568 do_warn_function_elimination (gfc_expr
*e
)
570 if (e
->expr_type
!= EXPR_FUNCTION
)
572 if (e
->value
.function
.esym
)
573 gfc_warning ("Removing call to function '%s' at %L",
574 e
->value
.function
.esym
->name
, &(e
->where
));
575 else if (e
->value
.function
.isym
)
576 gfc_warning ("Removing call to function '%s' at %L",
577 e
->value
.function
.isym
->name
, &(e
->where
));
579 /* Callback function for the code walker for doing common function
580 elimination. This builds up the list of functions in the expression
581 and goes through them to detect duplicates, which it then replaces
585 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
586 void *data ATTRIBUTE_UNUSED
)
592 /* Don't do this optimization within OMP workshare. */
594 if (in_omp_workshare
)
600 expr_array
.release ();
602 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
604 /* Walk through all the functions. */
606 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
608 /* Skip if the function has been replaced by a variable already. */
609 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
616 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
619 newvar
= create_var (*ei
);
621 if (warn_function_elimination
)
622 do_warn_function_elimination (*ej
);
625 *ej
= gfc_copy_expr (newvar
);
632 /* We did all the necessary walking in this function. */
637 /* Callback function for common function elimination, called from
638 gfc_code_walker. This keeps track of the current code, in order
639 to insert statements as needed. */
642 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
645 inserted_block
= NULL
;
646 changed_statement
= NULL
;
648 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
649 and allocation on assigment are prohibited inside WHERE, and finally
650 masking an expression would lead to wrong-code when replacing
653 b = sum(foo(a) + foo(a))
664 if ((*c
)->op
== EXEC_WHERE
)
674 /* Dummy function for expression call back, for use when we
675 really don't want to do any walking. */
678 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
679 void *data ATTRIBUTE_UNUSED
)
685 /* Dummy function for code callback, for use when we really
686 don't want to do anything. */
688 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
689 int *walk_subtrees ATTRIBUTE_UNUSED
,
690 void *data ATTRIBUTE_UNUSED
)
695 /* Code callback function for converting
702 This is because common function elimination would otherwise place the
703 temporary variables outside the loop. */
706 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
707 void *data ATTRIBUTE_UNUSED
)
710 gfc_code
*c_if1
, *c_if2
, *c_exit
;
712 gfc_expr
*e_not
, *e_cond
;
714 if (co
->op
!= EXEC_DO_WHILE
)
717 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
722 /* Generate the condition of the if statement, which is .not. the original
724 e_not
= gfc_get_expr ();
725 e_not
->ts
= e_cond
->ts
;
726 e_not
->where
= e_cond
->where
;
727 e_not
->expr_type
= EXPR_OP
;
728 e_not
->value
.op
.op
= INTRINSIC_NOT
;
729 e_not
->value
.op
.op1
= e_cond
;
731 /* Generate the EXIT statement. */
732 c_exit
= XCNEW (gfc_code
);
733 c_exit
->op
= EXEC_EXIT
;
734 c_exit
->ext
.which_construct
= co
;
735 c_exit
->loc
= co
->loc
;
737 /* Generate the IF statement. */
738 c_if2
= XCNEW (gfc_code
);
740 c_if2
->expr1
= e_not
;
741 c_if2
->next
= c_exit
;
742 c_if2
->loc
= co
->loc
;
744 /* ... plus the one to chain it to. */
745 c_if1
= XCNEW (gfc_code
);
747 c_if1
->block
= c_if2
;
748 c_if1
->loc
= co
->loc
;
750 /* Make the DO WHILE loop into a DO block by replacing the condition
751 with a true constant. */
752 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
754 /* Hang the generated if statement into the loop body. */
756 loopblock
= co
->block
->next
;
757 co
->block
->next
= c_if1
;
758 c_if1
->next
= loopblock
;
763 /* Code callback function for converting
776 because otherwise common function elimination would place the BLOCKs
777 into the wrong place. */
780 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
781 void *data ATTRIBUTE_UNUSED
)
784 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
786 if (co
->op
!= EXEC_IF
)
789 /* This loop starts out with the first ELSE statement. */
790 else_stmt
= co
->block
->block
;
792 while (else_stmt
!= NULL
)
796 /* If there is no condition, we're done. */
797 if (else_stmt
->expr1
== NULL
)
800 next_else
= else_stmt
->block
;
802 /* Generate the new IF statement. */
803 c_if2
= XCNEW (gfc_code
);
805 c_if2
->expr1
= else_stmt
->expr1
;
806 c_if2
->next
= else_stmt
->next
;
807 c_if2
->loc
= else_stmt
->loc
;
808 c_if2
->block
= next_else
;
810 /* ... plus the one to chain it to. */
811 c_if1
= XCNEW (gfc_code
);
813 c_if1
->block
= c_if2
;
814 c_if1
->loc
= else_stmt
->loc
;
816 /* Insert the new IF after the ELSE. */
817 else_stmt
->expr1
= NULL
;
818 else_stmt
->next
= c_if1
;
819 else_stmt
->block
= NULL
;
821 else_stmt
= next_else
;
823 /* Don't walk subtrees. */
826 /* Optimize a namespace, including all contained namespaces. */
829 optimize_namespace (gfc_namespace
*ns
)
835 in_assoc_list
= false;
836 in_omp_workshare
= false;
838 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
839 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
840 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
841 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
843 /* BLOCKs are handled in the expression walker below. */
844 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
846 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
847 optimize_namespace (ns
);
852 optimize_reduction (gfc_namespace
*ns
)
855 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
856 callback_reduction
, NULL
);
858 /* BLOCKs are handled in the expression walker below. */
859 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
861 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
862 optimize_reduction (ns
);
869 a = matmul(b,c) ; a = a + d
870 where the array function is not elemental and not allocatable
871 and does not depend on the left-hand side.
875 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
880 if (e
->expr_type
== EXPR_OP
)
882 switch (e
->value
.op
.op
)
884 /* Unary operators and exponentiation: Only look at a single
887 case INTRINSIC_UPLUS
:
888 case INTRINSIC_UMINUS
:
889 case INTRINSIC_PARENTHESES
:
890 case INTRINSIC_POWER
:
891 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
895 case INTRINSIC_CONCAT
:
896 /* Do not do string concatenations. */
900 /* Binary operators. */
901 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
904 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
910 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
911 && ! (e
->value
.function
.esym
912 && (e
->value
.function
.esym
->attr
.elemental
913 || e
->value
.function
.esym
->attr
.allocatable
914 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
915 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
916 && ! (e
->value
.function
.isym
917 && (e
->value
.function
.isym
->elemental
918 || e
->ts
.type
!= c
->expr1
->ts
.type
919 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
920 && ! gfc_inline_intrinsic_function_p (e
))
926 /* Insert a new assignment statement after the current one. */
927 n
= XCNEW (gfc_code
);
933 n
->expr1
= gfc_copy_expr (c
->expr1
);
935 new_expr
= gfc_copy_expr (c
->expr1
);
943 /* Nothing to optimize. */
947 /* Remove unneeded TRIMs at the end of expressions. */
950 remove_trim (gfc_expr
*rhs
)
956 /* Check for a // b // trim(c). Looping is probably not
957 necessary because the parser usually generates
958 (// (// a b ) trim(c) ) , but better safe than sorry. */
960 while (rhs
->expr_type
== EXPR_OP
961 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
962 rhs
= rhs
->value
.op
.op2
;
964 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
965 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
967 strip_function_call (rhs
);
968 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
976 /* Optimizations for an assignment. */
979 optimize_assignment (gfc_code
* c
)
986 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
988 /* Optimize a = trim(b) to a = b. */
991 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
992 if (is_empty_string (rhs
))
993 rhs
->value
.character
.length
= 0;
996 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
997 optimize_binop_array_assignment (c
, &rhs
, false);
1001 /* Remove an unneeded function call, modifying the expression.
1002 This replaces the function call with the value of its
1003 first argument. The rest of the argument list is freed. */
1006 strip_function_call (gfc_expr
*e
)
1009 gfc_actual_arglist
*a
;
1011 a
= e
->value
.function
.actual
;
1013 /* We should have at least one argument. */
1014 gcc_assert (a
->expr
!= NULL
);
1018 /* Free the remaining arglist, if any. */
1020 gfc_free_actual_arglist (a
->next
);
1022 /* Graft the argument expression onto the original function. */
1028 /* Optimization of lexical comparison functions. */
1031 optimize_lexical_comparison (gfc_expr
*e
)
1033 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1036 switch (e
->value
.function
.isym
->id
)
1039 return optimize_comparison (e
, INTRINSIC_LE
);
1042 return optimize_comparison (e
, INTRINSIC_GE
);
1045 return optimize_comparison (e
, INTRINSIC_GT
);
1048 return optimize_comparison (e
, INTRINSIC_LT
);
1056 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1057 do CHARACTER because of possible pessimization involving character
1061 combine_array_constructor (gfc_expr
*e
)
1064 gfc_expr
*op1
, *op2
;
1067 gfc_constructor
*c
, *new_c
;
1068 gfc_constructor_base oldbase
, newbase
;
1071 /* Array constructors have rank one. */
1075 /* Don't try to combine association lists, this makes no sense
1076 and leads to an ICE. */
1080 op1
= e
->value
.op
.op1
;
1081 op2
= e
->value
.op
.op2
;
1083 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1084 scalar_first
= false;
1085 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1087 scalar_first
= true;
1088 op1
= e
->value
.op
.op2
;
1089 op2
= e
->value
.op
.op1
;
1094 if (op2
->ts
.type
== BT_CHARACTER
)
1097 scalar
= create_var (gfc_copy_expr (op2
));
1099 oldbase
= op1
->value
.constructor
;
1101 e
->expr_type
= EXPR_ARRAY
;
1103 for (c
= gfc_constructor_first (oldbase
); c
;
1104 c
= gfc_constructor_next (c
))
1106 new_expr
= gfc_get_expr ();
1107 new_expr
->ts
= e
->ts
;
1108 new_expr
->expr_type
= EXPR_OP
;
1109 new_expr
->rank
= c
->expr
->rank
;
1110 new_expr
->where
= c
->where
;
1111 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1115 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1116 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1120 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1121 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1124 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1125 new_c
->iterator
= c
->iterator
;
1129 gfc_free_expr (op1
);
1130 gfc_free_expr (op2
);
1131 gfc_free_expr (scalar
);
1133 e
->value
.constructor
= newbase
;
1137 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1138 2**k into ishift(1,k) */
1141 optimize_power (gfc_expr
*e
)
1143 gfc_expr
*op1
, *op2
;
1144 gfc_expr
*iand
, *ishft
;
1146 if (e
->ts
.type
!= BT_INTEGER
)
1149 op1
= e
->value
.op
.op1
;
1151 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1154 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1156 gfc_free_expr (op1
);
1158 op2
= e
->value
.op
.op2
;
1163 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1164 "_internal_iand", e
->where
, 2, op2
,
1165 gfc_get_int_expr (e
->ts
.kind
,
1168 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1169 "_internal_ishft", e
->where
, 2, iand
,
1170 gfc_get_int_expr (e
->ts
.kind
,
1173 e
->value
.op
.op
= INTRINSIC_MINUS
;
1174 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1175 e
->value
.op
.op2
= ishft
;
1178 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1180 gfc_free_expr (op1
);
1182 op2
= e
->value
.op
.op2
;
1186 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1187 "_internal_ishft", e
->where
, 2,
1188 gfc_get_int_expr (e
->ts
.kind
,
1195 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1197 op2
= e
->value
.op
.op2
;
1201 gfc_free_expr (op1
);
1202 gfc_free_expr (op2
);
1204 e
->expr_type
= EXPR_CONSTANT
;
1205 e
->value
.op
.op1
= NULL
;
1206 e
->value
.op
.op2
= NULL
;
1207 mpz_init_set_si (e
->value
.integer
, 1);
1208 /* Typespec and location are still OK. */
1215 /* Recursive optimization of operators. */
1218 optimize_op (gfc_expr
*e
)
1222 gfc_intrinsic_op op
= e
->value
.op
.op
;
1226 /* Only use new-style comparisons. */
1229 case INTRINSIC_EQ_OS
:
1233 case INTRINSIC_GE_OS
:
1237 case INTRINSIC_LE_OS
:
1241 case INTRINSIC_NE_OS
:
1245 case INTRINSIC_GT_OS
:
1249 case INTRINSIC_LT_OS
:
1265 changed
= optimize_comparison (e
, op
);
1268 /* Look at array constructors. */
1269 case INTRINSIC_PLUS
:
1270 case INTRINSIC_MINUS
:
1271 case INTRINSIC_TIMES
:
1272 case INTRINSIC_DIVIDE
:
1273 return combine_array_constructor (e
) || changed
;
1275 case INTRINSIC_POWER
:
1276 return optimize_power (e
);
1287 /* Return true if a constant string contains only blanks. */
1290 is_empty_string (gfc_expr
*e
)
1294 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1297 for (i
=0; i
< e
->value
.character
.length
; i
++)
1299 if (e
->value
.character
.string
[i
] != ' ')
1307 /* Insert a call to the intrinsic len_trim. Use a different name for
1308 the symbol tree so we don't run into trouble when the user has
1309 renamed len_trim for some reason. */
1312 get_len_trim_call (gfc_expr
*str
, int kind
)
1315 gfc_actual_arglist
*actual_arglist
, *next
;
1317 fcn
= gfc_get_expr ();
1318 fcn
->expr_type
= EXPR_FUNCTION
;
1319 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1320 actual_arglist
= gfc_get_actual_arglist ();
1321 actual_arglist
->expr
= str
;
1322 next
= gfc_get_actual_arglist ();
1323 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1324 actual_arglist
->next
= next
;
1326 fcn
->value
.function
.actual
= actual_arglist
;
1327 fcn
->where
= str
->where
;
1328 fcn
->ts
.type
= BT_INTEGER
;
1329 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1331 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1332 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1333 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1334 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1335 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1336 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1337 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1338 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1343 /* Optimize expressions for equality. */
1346 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1348 gfc_expr
*op1
, *op2
;
1352 gfc_actual_arglist
*firstarg
, *secondarg
;
1354 if (e
->expr_type
== EXPR_OP
)
1358 op1
= e
->value
.op
.op1
;
1359 op2
= e
->value
.op
.op2
;
1361 else if (e
->expr_type
== EXPR_FUNCTION
)
1363 /* One of the lexical comparison functions. */
1364 firstarg
= e
->value
.function
.actual
;
1365 secondarg
= firstarg
->next
;
1366 op1
= firstarg
->expr
;
1367 op2
= secondarg
->expr
;
1372 /* Strip off unneeded TRIM calls from string comparisons. */
1374 change
= remove_trim (op1
);
1376 if (remove_trim (op2
))
1379 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1380 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1381 handles them well). However, there are also cases that need a non-scalar
1382 argument. For example the any intrinsic. See PR 45380. */
1386 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1388 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1389 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1391 bool empty_op1
, empty_op2
;
1392 empty_op1
= is_empty_string (op1
);
1393 empty_op2
= is_empty_string (op2
);
1395 if (empty_op1
|| empty_op2
)
1401 /* This can only happen when an error for comparing
1402 characters of different kinds has already been issued. */
1403 if (empty_op1
&& empty_op2
)
1406 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1407 str
= empty_op1
? op2
: op1
;
1409 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1413 gfc_free_expr (op1
);
1415 gfc_free_expr (op2
);
1419 e
->value
.op
.op1
= fcn
;
1420 e
->value
.op
.op2
= zero
;
1425 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1427 if (flag_finite_math_only
1428 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1429 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1431 eq
= gfc_dep_compare_expr (op1
, op2
);
1434 /* Replace A // B < A // C with B < C, and A // B < C // B
1436 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1437 && op1
->expr_type
== EXPR_OP
1438 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1439 && op2
->expr_type
== EXPR_OP
1440 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1442 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1443 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1444 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1445 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1447 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1449 /* Watch out for 'A ' // x vs. 'A' // x. */
1451 if (op1_left
->expr_type
== EXPR_CONSTANT
1452 && op2_left
->expr_type
== EXPR_CONSTANT
1453 && op1_left
->value
.character
.length
1454 != op2_left
->value
.character
.length
)
1462 firstarg
->expr
= op1_right
;
1463 secondarg
->expr
= op2_right
;
1467 e
->value
.op
.op1
= op1_right
;
1468 e
->value
.op
.op2
= op2_right
;
1470 optimize_comparison (e
, op
);
1474 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1480 firstarg
->expr
= op1_left
;
1481 secondarg
->expr
= op2_left
;
1485 e
->value
.op
.op1
= op1_left
;
1486 e
->value
.op
.op2
= op2_left
;
1489 optimize_comparison (e
, op
);
1496 /* eq can only be -1, 0 or 1 at this point. */
1524 gfc_internal_error ("illegal OP in optimize_comparison");
1528 /* Replace the expression by a constant expression. The typespec
1529 and where remains the way it is. */
1532 e
->expr_type
= EXPR_CONSTANT
;
1533 e
->value
.logical
= result
;
1541 /* Optimize a trim function by replacing it with an equivalent substring
1542 involving a call to len_trim. This only works for expressions where
1543 variables are trimmed. Return true if anything was modified. */
1546 optimize_trim (gfc_expr
*e
)
1551 gfc_ref
**rr
= NULL
;
1553 /* Don't do this optimization within an argument list, because
1554 otherwise aliasing issues may occur. */
1556 if (count_arglist
!= 1)
1559 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1560 || e
->value
.function
.isym
== NULL
1561 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1564 a
= e
->value
.function
.actual
->expr
;
1566 if (a
->expr_type
!= EXPR_VARIABLE
)
1569 /* Follow all references to find the correct place to put the newly
1570 created reference. FIXME: Also handle substring references and
1571 array references. Array references cause strange regressions at
1576 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1578 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1583 strip_function_call (e
);
1588 /* Create the reference. */
1590 ref
= gfc_get_ref ();
1591 ref
->type
= REF_SUBSTRING
;
1593 /* Set the start of the reference. */
1595 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1597 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1599 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1601 /* Set the end of the reference to the call to len_trim. */
1603 ref
->u
.ss
.end
= fcn
;
1604 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1609 /* Optimize minloc(b), where b is rank 1 array, into
1610 (/ minloc(b, dim=1) /), and similarly for maxloc,
1611 as the latter forms are expanded inline. */
1614 optimize_minmaxloc (gfc_expr
**e
)
1617 gfc_actual_arglist
*a
;
1621 || fn
->value
.function
.actual
== NULL
1622 || fn
->value
.function
.actual
->expr
== NULL
1623 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1626 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1627 (*e
)->shape
= fn
->shape
;
1630 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1632 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1633 strcpy (name
, fn
->value
.function
.name
);
1634 p
= strstr (name
, "loc0");
1636 fn
->value
.function
.name
= gfc_get_string (name
);
1637 if (fn
->value
.function
.actual
->next
)
1639 a
= fn
->value
.function
.actual
->next
;
1640 gcc_assert (a
->expr
== NULL
);
1644 a
= gfc_get_actual_arglist ();
1645 fn
->value
.function
.actual
->next
= a
;
1647 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1649 mpz_set_ui (a
->expr
->value
.integer
, 1);
1652 /* Callback function for code checking that we do not pass a DO variable to an
1653 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1656 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1657 void *data ATTRIBUTE_UNUSED
)
1661 gfc_formal_arglist
*f
;
1662 gfc_actual_arglist
*a
;
1667 /* If the doloop_list grew, we have to truncate it here. */
1669 if ((unsigned) doloop_level
< doloop_list
.length())
1670 doloop_list
.truncate (doloop_level
);
1676 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1677 doloop_list
.safe_push (co
);
1679 doloop_list
.safe_push ((gfc_code
*) NULL
);
1684 if (co
->resolved_sym
== NULL
)
1687 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1689 /* Withot a formal arglist, there is only unknown INTENT,
1690 which we don't check for. */
1698 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1705 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1707 if (a
->expr
&& a
->expr
->symtree
1708 && a
->expr
->symtree
->n
.sym
== do_sym
)
1710 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1711 gfc_error_now_1 ("Variable '%s' at %L set to undefined "
1712 "value inside loop beginning at %L as "
1713 "INTENT(OUT) argument to subroutine '%s'",
1714 do_sym
->name
, &a
->expr
->where
,
1715 &doloop_list
[i
]->loc
,
1716 co
->symtree
->n
.sym
->name
);
1717 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1718 gfc_error_now_1 ("Variable '%s' at %L not definable inside "
1719 "loop beginning at %L as INTENT(INOUT) "
1720 "argument to subroutine '%s'",
1721 do_sym
->name
, &a
->expr
->where
,
1722 &doloop_list
[i
]->loc
,
1723 co
->symtree
->n
.sym
->name
);
1737 /* Callback function for functions checking that we do not pass a DO variable
1738 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1741 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1742 void *data ATTRIBUTE_UNUSED
)
1744 gfc_formal_arglist
*f
;
1745 gfc_actual_arglist
*a
;
1751 if (expr
->expr_type
!= EXPR_FUNCTION
)
1754 /* Intrinsic functions don't modify their arguments. */
1756 if (expr
->value
.function
.isym
)
1759 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1761 /* Without a formal arglist, there is only unknown INTENT,
1762 which we don't check for. */
1766 a
= expr
->value
.function
.actual
;
1770 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1777 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1779 if (a
->expr
&& a
->expr
->symtree
1780 && a
->expr
->symtree
->n
.sym
== do_sym
)
1782 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1783 gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
1784 "inside loop beginning at %L as INTENT(OUT) "
1785 "argument to function '%s'", do_sym
->name
,
1786 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1787 expr
->symtree
->n
.sym
->name
);
1788 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1789 gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
1790 " beginning at %L as INTENT(INOUT) argument to"
1791 " function '%s'", do_sym
->name
,
1792 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1793 expr
->symtree
->n
.sym
->name
);
1804 doloop_warn (gfc_namespace
*ns
)
1806 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1810 #define WALK_SUBEXPR(NODE) \
1813 result = gfc_expr_walker (&(NODE), exprfn, data); \
1818 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1820 /* Walk expression *E, calling EXPRFN on each expression in it. */
1823 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
1827 int walk_subtrees
= 1;
1828 gfc_actual_arglist
*a
;
1832 int result
= exprfn (e
, &walk_subtrees
, data
);
1836 switch ((*e
)->expr_type
)
1839 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
1840 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
1843 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
1844 WALK_SUBEXPR (a
->expr
);
1848 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
1849 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
1850 WALK_SUBEXPR (a
->expr
);
1853 case EXPR_STRUCTURE
:
1855 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
1856 c
= gfc_constructor_next (c
))
1858 if (c
->iterator
== NULL
)
1859 WALK_SUBEXPR (c
->expr
);
1863 WALK_SUBEXPR (c
->expr
);
1865 WALK_SUBEXPR (c
->iterator
->var
);
1866 WALK_SUBEXPR (c
->iterator
->start
);
1867 WALK_SUBEXPR (c
->iterator
->end
);
1868 WALK_SUBEXPR (c
->iterator
->step
);
1872 if ((*e
)->expr_type
!= EXPR_ARRAY
)
1875 /* Fall through to the variable case in order to walk the
1878 case EXPR_SUBSTRING
:
1880 for (r
= (*e
)->ref
; r
; r
= r
->next
)
1889 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
1891 for (i
=0; i
< ar
->dimen
; i
++)
1893 WALK_SUBEXPR (ar
->start
[i
]);
1894 WALK_SUBEXPR (ar
->end
[i
]);
1895 WALK_SUBEXPR (ar
->stride
[i
]);
1902 WALK_SUBEXPR (r
->u
.ss
.start
);
1903 WALK_SUBEXPR (r
->u
.ss
.end
);
1919 #define WALK_SUBCODE(NODE) \
1922 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
1928 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
1929 on each expression in it. If any of the hooks returns non-zero, that
1930 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
1931 no subcodes or subexpressions are traversed. */
1934 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
1937 for (; *c
; c
= &(*c
)->next
)
1939 int walk_subtrees
= 1;
1940 int result
= codefn (c
, &walk_subtrees
, data
);
1947 gfc_actual_arglist
*a
;
1949 gfc_association_list
*alist
;
1950 bool saved_in_omp_workshare
;
1952 /* There might be statement insertions before the current code,
1953 which must not affect the expression walker. */
1956 saved_in_omp_workshare
= in_omp_workshare
;
1962 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
1963 if (co
->ext
.block
.assoc
)
1965 bool saved_in_assoc_list
= in_assoc_list
;
1967 in_assoc_list
= true;
1968 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
1969 WALK_SUBEXPR (alist
->target
);
1971 in_assoc_list
= saved_in_assoc_list
;
1978 WALK_SUBEXPR (co
->ext
.iterator
->var
);
1979 WALK_SUBEXPR (co
->ext
.iterator
->start
);
1980 WALK_SUBEXPR (co
->ext
.iterator
->end
);
1981 WALK_SUBEXPR (co
->ext
.iterator
->step
);
1985 case EXEC_ASSIGN_CALL
:
1986 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
1987 WALK_SUBEXPR (a
->expr
);
1991 WALK_SUBEXPR (co
->expr1
);
1992 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
1993 WALK_SUBEXPR (a
->expr
);
1997 WALK_SUBEXPR (co
->expr1
);
1998 for (b
= co
->block
; b
; b
= b
->block
)
2001 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2003 WALK_SUBEXPR (cp
->low
);
2004 WALK_SUBEXPR (cp
->high
);
2006 WALK_SUBCODE (b
->next
);
2011 case EXEC_DEALLOCATE
:
2014 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
2015 WALK_SUBEXPR (a
->expr
);
2020 case EXEC_DO_CONCURRENT
:
2022 gfc_forall_iterator
*fa
;
2023 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2025 WALK_SUBEXPR (fa
->var
);
2026 WALK_SUBEXPR (fa
->start
);
2027 WALK_SUBEXPR (fa
->end
);
2028 WALK_SUBEXPR (fa
->stride
);
2030 if (co
->op
== EXEC_FORALL
)
2036 WALK_SUBEXPR (co
->ext
.open
->unit
);
2037 WALK_SUBEXPR (co
->ext
.open
->file
);
2038 WALK_SUBEXPR (co
->ext
.open
->status
);
2039 WALK_SUBEXPR (co
->ext
.open
->access
);
2040 WALK_SUBEXPR (co
->ext
.open
->form
);
2041 WALK_SUBEXPR (co
->ext
.open
->recl
);
2042 WALK_SUBEXPR (co
->ext
.open
->blank
);
2043 WALK_SUBEXPR (co
->ext
.open
->position
);
2044 WALK_SUBEXPR (co
->ext
.open
->action
);
2045 WALK_SUBEXPR (co
->ext
.open
->delim
);
2046 WALK_SUBEXPR (co
->ext
.open
->pad
);
2047 WALK_SUBEXPR (co
->ext
.open
->iostat
);
2048 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
2049 WALK_SUBEXPR (co
->ext
.open
->convert
);
2050 WALK_SUBEXPR (co
->ext
.open
->decimal
);
2051 WALK_SUBEXPR (co
->ext
.open
->encoding
);
2052 WALK_SUBEXPR (co
->ext
.open
->round
);
2053 WALK_SUBEXPR (co
->ext
.open
->sign
);
2054 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
2055 WALK_SUBEXPR (co
->ext
.open
->id
);
2056 WALK_SUBEXPR (co
->ext
.open
->newunit
);
2060 WALK_SUBEXPR (co
->ext
.close
->unit
);
2061 WALK_SUBEXPR (co
->ext
.close
->status
);
2062 WALK_SUBEXPR (co
->ext
.close
->iostat
);
2063 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
2066 case EXEC_BACKSPACE
:
2070 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
2071 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
2072 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
2076 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
2077 WALK_SUBEXPR (co
->ext
.inquire
->file
);
2078 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
2079 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
2080 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
2081 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
2082 WALK_SUBEXPR (co
->ext
.inquire
->number
);
2083 WALK_SUBEXPR (co
->ext
.inquire
->named
);
2084 WALK_SUBEXPR (co
->ext
.inquire
->name
);
2085 WALK_SUBEXPR (co
->ext
.inquire
->access
);
2086 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
2087 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
2088 WALK_SUBEXPR (co
->ext
.inquire
->form
);
2089 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
2090 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
2091 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
2092 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
2093 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
2094 WALK_SUBEXPR (co
->ext
.inquire
->position
);
2095 WALK_SUBEXPR (co
->ext
.inquire
->action
);
2096 WALK_SUBEXPR (co
->ext
.inquire
->read
);
2097 WALK_SUBEXPR (co
->ext
.inquire
->write
);
2098 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
2099 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
2100 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
2101 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
2102 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
2103 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
2104 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
2105 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
2106 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
2107 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
2108 WALK_SUBEXPR (co
->ext
.inquire
->id
);
2109 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
2110 WALK_SUBEXPR (co
->ext
.inquire
->size
);
2111 WALK_SUBEXPR (co
->ext
.inquire
->round
);
2115 WALK_SUBEXPR (co
->ext
.wait
->unit
);
2116 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
2117 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
2118 WALK_SUBEXPR (co
->ext
.wait
->id
);
2123 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
2124 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
2125 WALK_SUBEXPR (co
->ext
.dt
->rec
);
2126 WALK_SUBEXPR (co
->ext
.dt
->advance
);
2127 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
2128 WALK_SUBEXPR (co
->ext
.dt
->size
);
2129 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
2130 WALK_SUBEXPR (co
->ext
.dt
->id
);
2131 WALK_SUBEXPR (co
->ext
.dt
->pos
);
2132 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
2133 WALK_SUBEXPR (co
->ext
.dt
->blank
);
2134 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
2135 WALK_SUBEXPR (co
->ext
.dt
->delim
);
2136 WALK_SUBEXPR (co
->ext
.dt
->pad
);
2137 WALK_SUBEXPR (co
->ext
.dt
->round
);
2138 WALK_SUBEXPR (co
->ext
.dt
->sign
);
2139 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
2142 case EXEC_OMP_PARALLEL
:
2143 case EXEC_OMP_PARALLEL_DO
:
2144 case EXEC_OMP_PARALLEL_DO_SIMD
:
2145 case EXEC_OMP_PARALLEL_SECTIONS
:
2147 in_omp_workshare
= false;
2149 /* This goto serves as a shortcut to avoid code
2150 duplication or a larger if or switch statement. */
2151 goto check_omp_clauses
;
2153 case EXEC_OMP_WORKSHARE
:
2154 case EXEC_OMP_PARALLEL_WORKSHARE
:
2156 in_omp_workshare
= true;
2160 case EXEC_OMP_DISTRIBUTE
:
2161 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2162 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2163 case EXEC_OMP_DISTRIBUTE_SIMD
:
2165 case EXEC_OMP_DO_SIMD
:
2166 case EXEC_OMP_SECTIONS
:
2167 case EXEC_OMP_SINGLE
:
2168 case EXEC_OMP_END_SINGLE
:
2170 case EXEC_OMP_TARGET
:
2171 case EXEC_OMP_TARGET_DATA
:
2172 case EXEC_OMP_TARGET_TEAMS
:
2173 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2174 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2175 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2176 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2177 case EXEC_OMP_TARGET_UPDATE
:
2179 case EXEC_OMP_TEAMS
:
2180 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2181 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2182 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2183 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2185 /* Come to this label only from the
2186 EXEC_OMP_PARALLEL_* cases above. */
2190 if (co
->ext
.omp_clauses
)
2192 gfc_omp_namelist
*n
;
2193 static int list_types
[]
2194 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
2195 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
2197 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
2198 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
2199 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
2200 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
2201 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
2202 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
2203 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
2204 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
2205 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
2206 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
2208 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
2210 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
2212 WALK_SUBEXPR (n
->expr
);
2219 WALK_SUBEXPR (co
->expr1
);
2220 WALK_SUBEXPR (co
->expr2
);
2221 WALK_SUBEXPR (co
->expr3
);
2222 WALK_SUBEXPR (co
->expr4
);
2223 for (b
= co
->block
; b
; b
= b
->block
)
2225 WALK_SUBEXPR (b
->expr1
);
2226 WALK_SUBEXPR (b
->expr2
);
2227 WALK_SUBCODE (b
->next
);
2230 if (co
->op
== EXEC_FORALL
)
2233 if (co
->op
== EXEC_DO
)
2236 in_omp_workshare
= saved_in_omp_workshare
;