1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2015 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 *);
45 static void realloc_strings (gfc_namespace
*);
46 static gfc_expr
*create_var (gfc_expr
*);
48 /* How deep we are inside an argument list. */
50 static int count_arglist
;
52 /* Vector of gfc_expr ** we operate on. */
54 static vec
<gfc_expr
**> expr_array
;
56 /* Pointer to the gfc_code we currently work on - to be able to insert
57 a block before the statement. */
59 static gfc_code
**current_code
;
61 /* Pointer to the block to be inserted, and the statement we are
62 changing within the block. */
64 static gfc_code
*inserted_block
, **changed_statement
;
66 /* The namespace we are currently dealing with. */
68 static gfc_namespace
*current_ns
;
70 /* If we are within any forall loop. */
72 static int forall_level
;
74 /* Keep track of whether we are within an OMP workshare. */
76 static bool in_omp_workshare
;
78 /* Keep track of iterators for array constructors. */
80 static int iterator_level
;
82 /* Keep track of DO loop levels. */
84 static vec
<gfc_code
*> doloop_list
;
86 static int doloop_level
;
88 /* Vector of gfc_expr * to keep track of DO loops. */
90 struct my_struct
*evec
;
92 /* Keep track of association lists. */
94 static bool in_assoc_list
;
96 /* Entry point - run all passes for a namespace. */
99 gfc_run_passes (gfc_namespace
*ns
)
102 /* Warn about dubious DO loops where the index might
107 doloop_list
.release ();
109 if (flag_frontend_optimize
)
111 optimize_namespace (ns
);
112 optimize_reduction (ns
);
113 if (flag_dump_fortran_optimized
)
114 gfc_dump_parse_tree (ns
, stdout
);
116 expr_array
.release ();
119 if (flag_realloc_lhs
)
120 realloc_strings (ns
);
123 /* Callback for each gfc_code node invoked from check_realloc_strings.
124 For an allocatable LHS string which also appears as a variable on
136 realloc_string_callback (gfc_code
**c
, int *walk_subtrees
,
137 void *data ATTRIBUTE_UNUSED
)
139 gfc_expr
*expr1
, *expr2
;
144 if (co
->op
!= EXEC_ASSIGN
)
148 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
149 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
152 expr2
= gfc_discard_nops (co
->expr2
);
153 if (expr2
->expr_type
!= EXPR_VARIABLE
)
156 if (!gfc_check_dependency (expr1
, expr2
, true))
160 n
= create_var (expr2
);
165 /* Callback for each gfc_code node invoked through gfc_code_walker
166 from optimize_namespace. */
169 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
170 void *data ATTRIBUTE_UNUSED
)
177 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
178 || op
== EXEC_CALL_PPC
)
184 inserted_block
= NULL
;
185 changed_statement
= NULL
;
187 if (op
== EXEC_ASSIGN
)
188 optimize_assignment (*c
);
192 /* Callback for each gfc_expr node invoked through gfc_code_walker
193 from optimize_namespace. */
196 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
197 void *data ATTRIBUTE_UNUSED
)
201 if ((*e
)->expr_type
== EXPR_FUNCTION
)
204 function_expr
= true;
207 function_expr
= false;
209 if (optimize_trim (*e
))
210 gfc_simplify_expr (*e
, 0);
212 if (optimize_lexical_comparison (*e
))
213 gfc_simplify_expr (*e
, 0);
215 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
216 gfc_simplify_expr (*e
, 0);
218 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
219 switch ((*e
)->value
.function
.isym
->id
)
221 case GFC_ISYM_MINLOC
:
222 case GFC_ISYM_MAXLOC
:
223 optimize_minmaxloc (e
);
235 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
236 function is a scalar, just copy it; otherwise returns the new element, the
237 old one can be freed. */
240 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
242 gfc_expr
*fcn
, *e
= c
->expr
;
244 fcn
= gfc_copy_expr (e
);
247 gfc_constructor_base newbase
;
249 gfc_constructor
*new_c
;
252 new_expr
= gfc_get_expr ();
253 new_expr
->expr_type
= EXPR_ARRAY
;
254 new_expr
->ts
= e
->ts
;
255 new_expr
->where
= e
->where
;
257 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
258 new_c
->iterator
= c
->iterator
;
259 new_expr
->value
.constructor
= newbase
;
267 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
269 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
270 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
271 fn
->value
.function
.isym
->name
,
272 fn
->where
, 3, fcn
, NULL
, NULL
);
273 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
274 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
275 fn
->value
.function
.isym
->name
,
276 fn
->where
, 2, fcn
, NULL
);
278 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
280 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
286 /* Callback function for optimzation of reductions to scalars. Transform ANY
287 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
288 correspondingly. Handly only the simple cases without MASK and DIM. */
291 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
292 void *data ATTRIBUTE_UNUSED
)
297 gfc_actual_arglist
*a
;
298 gfc_actual_arglist
*dim
;
300 gfc_expr
*res
, *new_expr
;
301 gfc_actual_arglist
*mask
;
305 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
306 || fn
->value
.function
.isym
== NULL
)
309 id
= fn
->value
.function
.isym
->id
;
311 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
312 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
315 a
= fn
->value
.function
.actual
;
317 /* Don't handle MASK or DIM. */
321 if (dim
->expr
!= NULL
)
324 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
327 if ( mask
->expr
!= NULL
)
333 if (arg
->expr_type
!= EXPR_ARRAY
)
342 case GFC_ISYM_PRODUCT
:
343 op
= INTRINSIC_TIMES
;
358 c
= gfc_constructor_first (arg
->value
.constructor
);
360 /* Don't do any simplififcation if we have
361 - no element in the constructor or
362 - only have a single element in the array which contains an
368 res
= copy_walk_reduction_arg (c
, fn
);
370 c
= gfc_constructor_next (c
);
373 new_expr
= gfc_get_expr ();
374 new_expr
->ts
= fn
->ts
;
375 new_expr
->expr_type
= EXPR_OP
;
376 new_expr
->rank
= fn
->rank
;
377 new_expr
->where
= fn
->where
;
378 new_expr
->value
.op
.op
= op
;
379 new_expr
->value
.op
.op1
= res
;
380 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
382 c
= gfc_constructor_next (c
);
385 gfc_simplify_expr (res
, 0);
392 /* Callback function for common function elimination, called from cfe_expr_0.
393 Put all eligible function expressions into expr_array. */
396 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
397 void *data ATTRIBUTE_UNUSED
)
400 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
403 /* We don't do character functions with unknown charlens. */
404 if ((*e
)->ts
.type
== BT_CHARACTER
405 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
406 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
409 /* We don't do function elimination within FORALL statements, it can
410 lead to wrong-code in certain circumstances. */
412 if (forall_level
> 0)
415 /* Function elimination inside an iterator could lead to functions which
416 depend on iterator variables being moved outside. FIXME: We should check
417 if the functions do indeed depend on the iterator variable. */
419 if (iterator_level
> 0)
422 /* If we don't know the shape at compile time, we create an allocatable
423 temporary variable to hold the intermediate result, but only if
424 allocation on assignment is active. */
426 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
429 /* Skip the test for pure functions if -faggressive-function-elimination
431 if ((*e
)->value
.function
.esym
)
433 /* Don't create an array temporary for elemental functions. */
434 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
437 /* Only eliminate potentially impure functions if the
438 user specifically requested it. */
439 if (!flag_aggressive_function_elimination
440 && !(*e
)->value
.function
.esym
->attr
.pure
441 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
445 if ((*e
)->value
.function
.isym
)
447 /* Conversions are handled on the fly by the middle end,
448 transpose during trans-* stages and TRANSFER by the middle end. */
449 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
450 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
451 || gfc_inline_intrinsic_function_p (*e
))
454 /* Don't create an array temporary for elemental functions,
455 as this would be wasteful of memory.
456 FIXME: Create a scalar temporary during scalarization. */
457 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
460 if (!(*e
)->value
.function
.isym
->pure
)
464 expr_array
.safe_push (e
);
468 /* Auxiliary function to check if an expression is a temporary created by
472 is_fe_temp (gfc_expr
*e
)
474 if (e
->expr_type
!= EXPR_VARIABLE
)
477 return e
->symtree
->n
.sym
->attr
.fe_temp
;
480 /* Determine the length of a string, if it can be evaluated as a constant
481 expression. Return a newly allocated gfc_expr or NULL on failure.
482 If the user specified a substring which is potentially longer than
483 the string itself, the string will be padded with spaces, which
487 constant_string_length (gfc_expr
*e
)
497 length
= e
->ts
.u
.cl
->length
;
498 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
499 return gfc_copy_expr(length
);
502 /* Return length of substring, if constant. */
503 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
505 if (ref
->type
== REF_SUBSTRING
506 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
508 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
511 mpz_add_ui (res
->value
.integer
, value
, 1);
517 /* Return length of char symbol, if constant. */
519 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
520 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
521 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
527 /* Returns a new expression (a variable) to be used in place of the old one,
528 with an assignment statement before the current statement to set
529 the value of the variable. Creates a new BLOCK for the statement if
530 that hasn't already been done and puts the statement, plus the
531 newly created variables, in that block. Special cases: If the
532 expression is constant or a temporary which has already
533 been created, just copy it. */
536 create_var (gfc_expr
* e
)
538 char name
[GFC_MAX_SYMBOL_LEN
+1];
540 gfc_symtree
*symtree
;
547 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
548 return gfc_copy_expr (e
);
550 /* If the block hasn't already been created, do so. */
551 if (inserted_block
== NULL
)
553 inserted_block
= XCNEW (gfc_code
);
554 inserted_block
->op
= EXEC_BLOCK
;
555 inserted_block
->loc
= (*current_code
)->loc
;
556 ns
= gfc_build_block_ns (current_ns
);
557 inserted_block
->ext
.block
.ns
= ns
;
558 inserted_block
->ext
.block
.assoc
= NULL
;
560 ns
->code
= *current_code
;
562 /* If the statement has a label, make sure it is transferred to
563 the newly created block. */
565 if ((*current_code
)->here
)
567 inserted_block
->here
= (*current_code
)->here
;
568 (*current_code
)->here
= NULL
;
571 inserted_block
->next
= (*current_code
)->next
;
572 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
573 (*current_code
)->next
= NULL
;
574 /* Insert the BLOCK at the right position. */
575 *current_code
= inserted_block
;
576 ns
->parent
= current_ns
;
579 ns
= inserted_block
->ext
.block
.ns
;
581 sprintf(name
, "__var_%d",num
++);
582 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
585 symbol
= symtree
->n
.sym
;
590 symbol
->as
= gfc_get_array_spec ();
591 symbol
->as
->rank
= e
->rank
;
593 if (e
->shape
== NULL
)
595 /* We don't know the shape at compile time, so we use an
597 symbol
->as
->type
= AS_DEFERRED
;
598 symbol
->attr
.allocatable
= 1;
602 symbol
->as
->type
= AS_EXPLICIT
;
603 /* Copy the shape. */
604 for (i
=0; i
<e
->rank
; i
++)
608 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
610 mpz_set_si (p
->value
.integer
, 1);
611 symbol
->as
->lower
[i
] = p
;
613 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
615 mpz_set (q
->value
.integer
, e
->shape
[i
]);
616 symbol
->as
->upper
[i
] = q
;
621 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
625 length
= constant_string_length (e
);
628 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
629 symbol
->ts
.u
.cl
->length
= length
;
632 symbol
->attr
.allocatable
= 1;
635 symbol
->attr
.flavor
= FL_VARIABLE
;
636 symbol
->attr
.referenced
= 1;
637 symbol
->attr
.dimension
= e
->rank
> 0;
638 symbol
->attr
.fe_temp
= 1;
639 gfc_commit_symbol (symbol
);
641 result
= gfc_get_expr ();
642 result
->expr_type
= EXPR_VARIABLE
;
644 result
->rank
= e
->rank
;
645 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
646 result
->symtree
= symtree
;
647 result
->where
= e
->where
;
650 result
->ref
= gfc_get_ref ();
651 result
->ref
->type
= REF_ARRAY
;
652 result
->ref
->u
.ar
.type
= AR_FULL
;
653 result
->ref
->u
.ar
.where
= e
->where
;
654 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
655 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
656 if (warn_array_temporaries
)
657 gfc_warning (OPT_Warray_temporaries
,
658 "Creating array temporary at %L", &(e
->where
));
661 /* Generate the new assignment. */
662 n
= XCNEW (gfc_code
);
664 n
->loc
= (*current_code
)->loc
;
665 n
->next
= *changed_statement
;
666 n
->expr1
= gfc_copy_expr (result
);
668 *changed_statement
= n
;
673 /* Warn about function elimination. */
676 do_warn_function_elimination (gfc_expr
*e
)
678 if (e
->expr_type
!= EXPR_FUNCTION
)
680 if (e
->value
.function
.esym
)
681 gfc_warning ("Removing call to function %qs at %L",
682 e
->value
.function
.esym
->name
, &(e
->where
));
683 else if (e
->value
.function
.isym
)
684 gfc_warning ("Removing call to function %qs at %L",
685 e
->value
.function
.isym
->name
, &(e
->where
));
687 /* Callback function for the code walker for doing common function
688 elimination. This builds up the list of functions in the expression
689 and goes through them to detect duplicates, which it then replaces
693 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
694 void *data ATTRIBUTE_UNUSED
)
700 /* Don't do this optimization within OMP workshare. */
702 if (in_omp_workshare
)
708 expr_array
.release ();
710 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
712 /* Walk through all the functions. */
714 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
716 /* Skip if the function has been replaced by a variable already. */
717 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
724 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
727 newvar
= create_var (*ei
);
729 if (warn_function_elimination
)
730 do_warn_function_elimination (*ej
);
733 *ej
= gfc_copy_expr (newvar
);
740 /* We did all the necessary walking in this function. */
745 /* Callback function for common function elimination, called from
746 gfc_code_walker. This keeps track of the current code, in order
747 to insert statements as needed. */
750 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
753 inserted_block
= NULL
;
754 changed_statement
= NULL
;
756 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
757 and allocation on assigment are prohibited inside WHERE, and finally
758 masking an expression would lead to wrong-code when replacing
761 b = sum(foo(a) + foo(a))
772 if ((*c
)->op
== EXEC_WHERE
)
782 /* Dummy function for expression call back, for use when we
783 really don't want to do any walking. */
786 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
787 void *data ATTRIBUTE_UNUSED
)
793 /* Dummy function for code callback, for use when we really
794 don't want to do anything. */
796 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
797 int *walk_subtrees ATTRIBUTE_UNUSED
,
798 void *data ATTRIBUTE_UNUSED
)
803 /* Code callback function for converting
810 This is because common function elimination would otherwise place the
811 temporary variables outside the loop. */
814 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
815 void *data ATTRIBUTE_UNUSED
)
818 gfc_code
*c_if1
, *c_if2
, *c_exit
;
820 gfc_expr
*e_not
, *e_cond
;
822 if (co
->op
!= EXEC_DO_WHILE
)
825 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
830 /* Generate the condition of the if statement, which is .not. the original
832 e_not
= gfc_get_expr ();
833 e_not
->ts
= e_cond
->ts
;
834 e_not
->where
= e_cond
->where
;
835 e_not
->expr_type
= EXPR_OP
;
836 e_not
->value
.op
.op
= INTRINSIC_NOT
;
837 e_not
->value
.op
.op1
= e_cond
;
839 /* Generate the EXIT statement. */
840 c_exit
= XCNEW (gfc_code
);
841 c_exit
->op
= EXEC_EXIT
;
842 c_exit
->ext
.which_construct
= co
;
843 c_exit
->loc
= co
->loc
;
845 /* Generate the IF statement. */
846 c_if2
= XCNEW (gfc_code
);
848 c_if2
->expr1
= e_not
;
849 c_if2
->next
= c_exit
;
850 c_if2
->loc
= co
->loc
;
852 /* ... plus the one to chain it to. */
853 c_if1
= XCNEW (gfc_code
);
855 c_if1
->block
= c_if2
;
856 c_if1
->loc
= co
->loc
;
858 /* Make the DO WHILE loop into a DO block by replacing the condition
859 with a true constant. */
860 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
862 /* Hang the generated if statement into the loop body. */
864 loopblock
= co
->block
->next
;
865 co
->block
->next
= c_if1
;
866 c_if1
->next
= loopblock
;
871 /* Code callback function for converting
884 because otherwise common function elimination would place the BLOCKs
885 into the wrong place. */
888 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
889 void *data ATTRIBUTE_UNUSED
)
892 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
894 if (co
->op
!= EXEC_IF
)
897 /* This loop starts out with the first ELSE statement. */
898 else_stmt
= co
->block
->block
;
900 while (else_stmt
!= NULL
)
904 /* If there is no condition, we're done. */
905 if (else_stmt
->expr1
== NULL
)
908 next_else
= else_stmt
->block
;
910 /* Generate the new IF statement. */
911 c_if2
= XCNEW (gfc_code
);
913 c_if2
->expr1
= else_stmt
->expr1
;
914 c_if2
->next
= else_stmt
->next
;
915 c_if2
->loc
= else_stmt
->loc
;
916 c_if2
->block
= next_else
;
918 /* ... plus the one to chain it to. */
919 c_if1
= XCNEW (gfc_code
);
921 c_if1
->block
= c_if2
;
922 c_if1
->loc
= else_stmt
->loc
;
924 /* Insert the new IF after the ELSE. */
925 else_stmt
->expr1
= NULL
;
926 else_stmt
->next
= c_if1
;
927 else_stmt
->block
= NULL
;
929 else_stmt
= next_else
;
931 /* Don't walk subtrees. */
934 /* Optimize a namespace, including all contained namespaces. */
937 optimize_namespace (gfc_namespace
*ns
)
943 in_assoc_list
= false;
944 in_omp_workshare
= false;
946 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
947 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
948 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
949 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
951 /* BLOCKs are handled in the expression walker below. */
952 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
954 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
955 optimize_namespace (ns
);
959 /* Handle dependencies for allocatable strings which potentially redefine
960 themselves in an assignment. */
963 realloc_strings (gfc_namespace
*ns
)
966 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
968 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
970 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
973 realloc_strings (ns
);
980 optimize_reduction (gfc_namespace
*ns
)
983 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
984 callback_reduction
, NULL
);
986 /* BLOCKs are handled in the expression walker below. */
987 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
989 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
990 optimize_reduction (ns
);
997 a = matmul(b,c) ; a = a + d
998 where the array function is not elemental and not allocatable
999 and does not depend on the left-hand side.
1003 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1008 if (e
->expr_type
== EXPR_OP
)
1010 switch (e
->value
.op
.op
)
1012 /* Unary operators and exponentiation: Only look at a single
1015 case INTRINSIC_UPLUS
:
1016 case INTRINSIC_UMINUS
:
1017 case INTRINSIC_PARENTHESES
:
1018 case INTRINSIC_POWER
:
1019 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1023 case INTRINSIC_CONCAT
:
1024 /* Do not do string concatenations. */
1028 /* Binary operators. */
1029 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1032 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1038 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1039 && ! (e
->value
.function
.esym
1040 && (e
->value
.function
.esym
->attr
.elemental
1041 || e
->value
.function
.esym
->attr
.allocatable
1042 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1043 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1044 && ! (e
->value
.function
.isym
1045 && (e
->value
.function
.isym
->elemental
1046 || e
->ts
.type
!= c
->expr1
->ts
.type
1047 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1048 && ! gfc_inline_intrinsic_function_p (e
))
1054 /* Insert a new assignment statement after the current one. */
1055 n
= XCNEW (gfc_code
);
1056 n
->op
= EXEC_ASSIGN
;
1061 n
->expr1
= gfc_copy_expr (c
->expr1
);
1062 n
->expr2
= c
->expr2
;
1063 new_expr
= gfc_copy_expr (c
->expr1
);
1071 /* Nothing to optimize. */
1075 /* Remove unneeded TRIMs at the end of expressions. */
1078 remove_trim (gfc_expr
*rhs
)
1084 /* Check for a // b // trim(c). Looping is probably not
1085 necessary because the parser usually generates
1086 (// (// a b ) trim(c) ) , but better safe than sorry. */
1088 while (rhs
->expr_type
== EXPR_OP
1089 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1090 rhs
= rhs
->value
.op
.op2
;
1092 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1093 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1095 strip_function_call (rhs
);
1096 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1104 /* Optimizations for an assignment. */
1107 optimize_assignment (gfc_code
* c
)
1109 gfc_expr
*lhs
, *rhs
;
1114 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1116 /* Optimize a = trim(b) to a = b. */
1119 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1120 if (is_empty_string (rhs
))
1121 rhs
->value
.character
.length
= 0;
1124 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1125 optimize_binop_array_assignment (c
, &rhs
, false);
1129 /* Remove an unneeded function call, modifying the expression.
1130 This replaces the function call with the value of its
1131 first argument. The rest of the argument list is freed. */
1134 strip_function_call (gfc_expr
*e
)
1137 gfc_actual_arglist
*a
;
1139 a
= e
->value
.function
.actual
;
1141 /* We should have at least one argument. */
1142 gcc_assert (a
->expr
!= NULL
);
1146 /* Free the remaining arglist, if any. */
1148 gfc_free_actual_arglist (a
->next
);
1150 /* Graft the argument expression onto the original function. */
1156 /* Optimization of lexical comparison functions. */
1159 optimize_lexical_comparison (gfc_expr
*e
)
1161 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1164 switch (e
->value
.function
.isym
->id
)
1167 return optimize_comparison (e
, INTRINSIC_LE
);
1170 return optimize_comparison (e
, INTRINSIC_GE
);
1173 return optimize_comparison (e
, INTRINSIC_GT
);
1176 return optimize_comparison (e
, INTRINSIC_LT
);
1184 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1185 do CHARACTER because of possible pessimization involving character
1189 combine_array_constructor (gfc_expr
*e
)
1192 gfc_expr
*op1
, *op2
;
1195 gfc_constructor
*c
, *new_c
;
1196 gfc_constructor_base oldbase
, newbase
;
1199 /* Array constructors have rank one. */
1203 /* Don't try to combine association lists, this makes no sense
1204 and leads to an ICE. */
1208 op1
= e
->value
.op
.op1
;
1209 op2
= e
->value
.op
.op2
;
1211 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1212 scalar_first
= false;
1213 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1215 scalar_first
= true;
1216 op1
= e
->value
.op
.op2
;
1217 op2
= e
->value
.op
.op1
;
1222 if (op2
->ts
.type
== BT_CHARACTER
)
1225 scalar
= create_var (gfc_copy_expr (op2
));
1227 oldbase
= op1
->value
.constructor
;
1229 e
->expr_type
= EXPR_ARRAY
;
1231 for (c
= gfc_constructor_first (oldbase
); c
;
1232 c
= gfc_constructor_next (c
))
1234 new_expr
= gfc_get_expr ();
1235 new_expr
->ts
= e
->ts
;
1236 new_expr
->expr_type
= EXPR_OP
;
1237 new_expr
->rank
= c
->expr
->rank
;
1238 new_expr
->where
= c
->where
;
1239 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1243 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1244 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1248 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1249 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1252 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1253 new_c
->iterator
= c
->iterator
;
1257 gfc_free_expr (op1
);
1258 gfc_free_expr (op2
);
1259 gfc_free_expr (scalar
);
1261 e
->value
.constructor
= newbase
;
1265 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1266 2**k into ishift(1,k) */
1269 optimize_power (gfc_expr
*e
)
1271 gfc_expr
*op1
, *op2
;
1272 gfc_expr
*iand
, *ishft
;
1274 if (e
->ts
.type
!= BT_INTEGER
)
1277 op1
= e
->value
.op
.op1
;
1279 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1282 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1284 gfc_free_expr (op1
);
1286 op2
= e
->value
.op
.op2
;
1291 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1292 "_internal_iand", e
->where
, 2, op2
,
1293 gfc_get_int_expr (e
->ts
.kind
,
1296 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1297 "_internal_ishft", e
->where
, 2, iand
,
1298 gfc_get_int_expr (e
->ts
.kind
,
1301 e
->value
.op
.op
= INTRINSIC_MINUS
;
1302 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1303 e
->value
.op
.op2
= ishft
;
1306 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1308 gfc_free_expr (op1
);
1310 op2
= e
->value
.op
.op2
;
1314 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1315 "_internal_ishft", e
->where
, 2,
1316 gfc_get_int_expr (e
->ts
.kind
,
1323 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1325 op2
= e
->value
.op
.op2
;
1329 gfc_free_expr (op1
);
1330 gfc_free_expr (op2
);
1332 e
->expr_type
= EXPR_CONSTANT
;
1333 e
->value
.op
.op1
= NULL
;
1334 e
->value
.op
.op2
= NULL
;
1335 mpz_init_set_si (e
->value
.integer
, 1);
1336 /* Typespec and location are still OK. */
1343 /* Recursive optimization of operators. */
1346 optimize_op (gfc_expr
*e
)
1350 gfc_intrinsic_op op
= e
->value
.op
.op
;
1354 /* Only use new-style comparisons. */
1357 case INTRINSIC_EQ_OS
:
1361 case INTRINSIC_GE_OS
:
1365 case INTRINSIC_LE_OS
:
1369 case INTRINSIC_NE_OS
:
1373 case INTRINSIC_GT_OS
:
1377 case INTRINSIC_LT_OS
:
1393 changed
= optimize_comparison (e
, op
);
1396 /* Look at array constructors. */
1397 case INTRINSIC_PLUS
:
1398 case INTRINSIC_MINUS
:
1399 case INTRINSIC_TIMES
:
1400 case INTRINSIC_DIVIDE
:
1401 return combine_array_constructor (e
) || changed
;
1403 case INTRINSIC_POWER
:
1404 return optimize_power (e
);
1415 /* Return true if a constant string contains only blanks. */
1418 is_empty_string (gfc_expr
*e
)
1422 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1425 for (i
=0; i
< e
->value
.character
.length
; i
++)
1427 if (e
->value
.character
.string
[i
] != ' ')
1435 /* Insert a call to the intrinsic len_trim. Use a different name for
1436 the symbol tree so we don't run into trouble when the user has
1437 renamed len_trim for some reason. */
1440 get_len_trim_call (gfc_expr
*str
, int kind
)
1443 gfc_actual_arglist
*actual_arglist
, *next
;
1445 fcn
= gfc_get_expr ();
1446 fcn
->expr_type
= EXPR_FUNCTION
;
1447 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1448 actual_arglist
= gfc_get_actual_arglist ();
1449 actual_arglist
->expr
= str
;
1450 next
= gfc_get_actual_arglist ();
1451 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1452 actual_arglist
->next
= next
;
1454 fcn
->value
.function
.actual
= actual_arglist
;
1455 fcn
->where
= str
->where
;
1456 fcn
->ts
.type
= BT_INTEGER
;
1457 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1459 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1460 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1461 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1462 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1463 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1464 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1465 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1466 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1471 /* Optimize expressions for equality. */
1474 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1476 gfc_expr
*op1
, *op2
;
1480 gfc_actual_arglist
*firstarg
, *secondarg
;
1482 if (e
->expr_type
== EXPR_OP
)
1486 op1
= e
->value
.op
.op1
;
1487 op2
= e
->value
.op
.op2
;
1489 else if (e
->expr_type
== EXPR_FUNCTION
)
1491 /* One of the lexical comparison functions. */
1492 firstarg
= e
->value
.function
.actual
;
1493 secondarg
= firstarg
->next
;
1494 op1
= firstarg
->expr
;
1495 op2
= secondarg
->expr
;
1500 /* Strip off unneeded TRIM calls from string comparisons. */
1502 change
= remove_trim (op1
);
1504 if (remove_trim (op2
))
1507 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1508 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1509 handles them well). However, there are also cases that need a non-scalar
1510 argument. For example the any intrinsic. See PR 45380. */
1514 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1516 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1517 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1519 bool empty_op1
, empty_op2
;
1520 empty_op1
= is_empty_string (op1
);
1521 empty_op2
= is_empty_string (op2
);
1523 if (empty_op1
|| empty_op2
)
1529 /* This can only happen when an error for comparing
1530 characters of different kinds has already been issued. */
1531 if (empty_op1
&& empty_op2
)
1534 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1535 str
= empty_op1
? op2
: op1
;
1537 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1541 gfc_free_expr (op1
);
1543 gfc_free_expr (op2
);
1547 e
->value
.op
.op1
= fcn
;
1548 e
->value
.op
.op2
= zero
;
1553 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1555 if (flag_finite_math_only
1556 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1557 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1559 eq
= gfc_dep_compare_expr (op1
, op2
);
1562 /* Replace A // B < A // C with B < C, and A // B < C // B
1564 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1565 && op1
->expr_type
== EXPR_OP
1566 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1567 && op2
->expr_type
== EXPR_OP
1568 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1570 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1571 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1572 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1573 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1575 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1577 /* Watch out for 'A ' // x vs. 'A' // x. */
1579 if (op1_left
->expr_type
== EXPR_CONSTANT
1580 && op2_left
->expr_type
== EXPR_CONSTANT
1581 && op1_left
->value
.character
.length
1582 != op2_left
->value
.character
.length
)
1590 firstarg
->expr
= op1_right
;
1591 secondarg
->expr
= op2_right
;
1595 e
->value
.op
.op1
= op1_right
;
1596 e
->value
.op
.op2
= op2_right
;
1598 optimize_comparison (e
, op
);
1602 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1608 firstarg
->expr
= op1_left
;
1609 secondarg
->expr
= op2_left
;
1613 e
->value
.op
.op1
= op1_left
;
1614 e
->value
.op
.op2
= op2_left
;
1617 optimize_comparison (e
, op
);
1624 /* eq can only be -1, 0 or 1 at this point. */
1652 gfc_internal_error ("illegal OP in optimize_comparison");
1656 /* Replace the expression by a constant expression. The typespec
1657 and where remains the way it is. */
1660 e
->expr_type
= EXPR_CONSTANT
;
1661 e
->value
.logical
= result
;
1669 /* Optimize a trim function by replacing it with an equivalent substring
1670 involving a call to len_trim. This only works for expressions where
1671 variables are trimmed. Return true if anything was modified. */
1674 optimize_trim (gfc_expr
*e
)
1679 gfc_ref
**rr
= NULL
;
1681 /* Don't do this optimization within an argument list, because
1682 otherwise aliasing issues may occur. */
1684 if (count_arglist
!= 1)
1687 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1688 || e
->value
.function
.isym
== NULL
1689 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1692 a
= e
->value
.function
.actual
->expr
;
1694 if (a
->expr_type
!= EXPR_VARIABLE
)
1697 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1699 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1702 /* Follow all references to find the correct place to put the newly
1703 created reference. FIXME: Also handle substring references and
1704 array references. Array references cause strange regressions at
1709 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1711 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1716 strip_function_call (e
);
1721 /* Create the reference. */
1723 ref
= gfc_get_ref ();
1724 ref
->type
= REF_SUBSTRING
;
1726 /* Set the start of the reference. */
1728 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1730 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1732 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1734 /* Set the end of the reference to the call to len_trim. */
1736 ref
->u
.ss
.end
= fcn
;
1737 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1742 /* Optimize minloc(b), where b is rank 1 array, into
1743 (/ minloc(b, dim=1) /), and similarly for maxloc,
1744 as the latter forms are expanded inline. */
1747 optimize_minmaxloc (gfc_expr
**e
)
1750 gfc_actual_arglist
*a
;
1754 || fn
->value
.function
.actual
== NULL
1755 || fn
->value
.function
.actual
->expr
== NULL
1756 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1759 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1760 (*e
)->shape
= fn
->shape
;
1763 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1765 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1766 strcpy (name
, fn
->value
.function
.name
);
1767 p
= strstr (name
, "loc0");
1769 fn
->value
.function
.name
= gfc_get_string (name
);
1770 if (fn
->value
.function
.actual
->next
)
1772 a
= fn
->value
.function
.actual
->next
;
1773 gcc_assert (a
->expr
== NULL
);
1777 a
= gfc_get_actual_arglist ();
1778 fn
->value
.function
.actual
->next
= a
;
1780 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1782 mpz_set_ui (a
->expr
->value
.integer
, 1);
1785 /* Callback function for code checking that we do not pass a DO variable to an
1786 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1789 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1790 void *data ATTRIBUTE_UNUSED
)
1794 gfc_formal_arglist
*f
;
1795 gfc_actual_arglist
*a
;
1800 /* If the doloop_list grew, we have to truncate it here. */
1802 if ((unsigned) doloop_level
< doloop_list
.length())
1803 doloop_list
.truncate (doloop_level
);
1809 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1810 doloop_list
.safe_push (co
);
1812 doloop_list
.safe_push ((gfc_code
*) NULL
);
1817 if (co
->resolved_sym
== NULL
)
1820 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1822 /* Withot a formal arglist, there is only unknown INTENT,
1823 which we don't check for. */
1831 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1838 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1840 if (a
->expr
&& a
->expr
->symtree
1841 && a
->expr
->symtree
->n
.sym
== do_sym
)
1843 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1844 gfc_error_now_1 ("Variable '%s' at %L set to undefined "
1845 "value inside loop beginning at %L as "
1846 "INTENT(OUT) argument to subroutine '%s'",
1847 do_sym
->name
, &a
->expr
->where
,
1848 &doloop_list
[i
]->loc
,
1849 co
->symtree
->n
.sym
->name
);
1850 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1851 gfc_error_now_1 ("Variable '%s' at %L not definable inside "
1852 "loop beginning at %L as INTENT(INOUT) "
1853 "argument to subroutine '%s'",
1854 do_sym
->name
, &a
->expr
->where
,
1855 &doloop_list
[i
]->loc
,
1856 co
->symtree
->n
.sym
->name
);
1870 /* Callback function for functions checking that we do not pass a DO variable
1871 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1874 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1875 void *data ATTRIBUTE_UNUSED
)
1877 gfc_formal_arglist
*f
;
1878 gfc_actual_arglist
*a
;
1884 if (expr
->expr_type
!= EXPR_FUNCTION
)
1887 /* Intrinsic functions don't modify their arguments. */
1889 if (expr
->value
.function
.isym
)
1892 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1894 /* Without a formal arglist, there is only unknown INTENT,
1895 which we don't check for. */
1899 a
= expr
->value
.function
.actual
;
1903 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1910 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1912 if (a
->expr
&& a
->expr
->symtree
1913 && a
->expr
->symtree
->n
.sym
== do_sym
)
1915 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1916 gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
1917 "inside loop beginning at %L as INTENT(OUT) "
1918 "argument to function '%s'", do_sym
->name
,
1919 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1920 expr
->symtree
->n
.sym
->name
);
1921 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1922 gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
1923 " beginning at %L as INTENT(INOUT) argument to"
1924 " function '%s'", do_sym
->name
,
1925 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1926 expr
->symtree
->n
.sym
->name
);
1937 doloop_warn (gfc_namespace
*ns
)
1939 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1943 #define WALK_SUBEXPR(NODE) \
1946 result = gfc_expr_walker (&(NODE), exprfn, data); \
1951 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
1953 /* Walk expression *E, calling EXPRFN on each expression in it. */
1956 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
1960 int walk_subtrees
= 1;
1961 gfc_actual_arglist
*a
;
1965 int result
= exprfn (e
, &walk_subtrees
, data
);
1969 switch ((*e
)->expr_type
)
1972 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
1973 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
1976 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
1977 WALK_SUBEXPR (a
->expr
);
1981 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
1982 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
1983 WALK_SUBEXPR (a
->expr
);
1986 case EXPR_STRUCTURE
:
1988 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
1989 c
= gfc_constructor_next (c
))
1991 if (c
->iterator
== NULL
)
1992 WALK_SUBEXPR (c
->expr
);
1996 WALK_SUBEXPR (c
->expr
);
1998 WALK_SUBEXPR (c
->iterator
->var
);
1999 WALK_SUBEXPR (c
->iterator
->start
);
2000 WALK_SUBEXPR (c
->iterator
->end
);
2001 WALK_SUBEXPR (c
->iterator
->step
);
2005 if ((*e
)->expr_type
!= EXPR_ARRAY
)
2008 /* Fall through to the variable case in order to walk the
2011 case EXPR_SUBSTRING
:
2013 for (r
= (*e
)->ref
; r
; r
= r
->next
)
2022 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
2024 for (i
=0; i
< ar
->dimen
; i
++)
2026 WALK_SUBEXPR (ar
->start
[i
]);
2027 WALK_SUBEXPR (ar
->end
[i
]);
2028 WALK_SUBEXPR (ar
->stride
[i
]);
2035 WALK_SUBEXPR (r
->u
.ss
.start
);
2036 WALK_SUBEXPR (r
->u
.ss
.end
);
2052 #define WALK_SUBCODE(NODE) \
2055 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
2061 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
2062 on each expression in it. If any of the hooks returns non-zero, that
2063 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
2064 no subcodes or subexpressions are traversed. */
2067 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
2070 for (; *c
; c
= &(*c
)->next
)
2072 int walk_subtrees
= 1;
2073 int result
= codefn (c
, &walk_subtrees
, data
);
2080 gfc_actual_arglist
*a
;
2082 gfc_association_list
*alist
;
2083 bool saved_in_omp_workshare
;
2085 /* There might be statement insertions before the current code,
2086 which must not affect the expression walker. */
2089 saved_in_omp_workshare
= in_omp_workshare
;
2095 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
2096 if (co
->ext
.block
.assoc
)
2098 bool saved_in_assoc_list
= in_assoc_list
;
2100 in_assoc_list
= true;
2101 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
2102 WALK_SUBEXPR (alist
->target
);
2104 in_assoc_list
= saved_in_assoc_list
;
2111 WALK_SUBEXPR (co
->ext
.iterator
->var
);
2112 WALK_SUBEXPR (co
->ext
.iterator
->start
);
2113 WALK_SUBEXPR (co
->ext
.iterator
->end
);
2114 WALK_SUBEXPR (co
->ext
.iterator
->step
);
2118 case EXEC_ASSIGN_CALL
:
2119 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
2120 WALK_SUBEXPR (a
->expr
);
2124 WALK_SUBEXPR (co
->expr1
);
2125 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
2126 WALK_SUBEXPR (a
->expr
);
2130 WALK_SUBEXPR (co
->expr1
);
2131 for (b
= co
->block
; b
; b
= b
->block
)
2134 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2136 WALK_SUBEXPR (cp
->low
);
2137 WALK_SUBEXPR (cp
->high
);
2139 WALK_SUBCODE (b
->next
);
2144 case EXEC_DEALLOCATE
:
2147 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
2148 WALK_SUBEXPR (a
->expr
);
2153 case EXEC_DO_CONCURRENT
:
2155 gfc_forall_iterator
*fa
;
2156 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2158 WALK_SUBEXPR (fa
->var
);
2159 WALK_SUBEXPR (fa
->start
);
2160 WALK_SUBEXPR (fa
->end
);
2161 WALK_SUBEXPR (fa
->stride
);
2163 if (co
->op
== EXEC_FORALL
)
2169 WALK_SUBEXPR (co
->ext
.open
->unit
);
2170 WALK_SUBEXPR (co
->ext
.open
->file
);
2171 WALK_SUBEXPR (co
->ext
.open
->status
);
2172 WALK_SUBEXPR (co
->ext
.open
->access
);
2173 WALK_SUBEXPR (co
->ext
.open
->form
);
2174 WALK_SUBEXPR (co
->ext
.open
->recl
);
2175 WALK_SUBEXPR (co
->ext
.open
->blank
);
2176 WALK_SUBEXPR (co
->ext
.open
->position
);
2177 WALK_SUBEXPR (co
->ext
.open
->action
);
2178 WALK_SUBEXPR (co
->ext
.open
->delim
);
2179 WALK_SUBEXPR (co
->ext
.open
->pad
);
2180 WALK_SUBEXPR (co
->ext
.open
->iostat
);
2181 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
2182 WALK_SUBEXPR (co
->ext
.open
->convert
);
2183 WALK_SUBEXPR (co
->ext
.open
->decimal
);
2184 WALK_SUBEXPR (co
->ext
.open
->encoding
);
2185 WALK_SUBEXPR (co
->ext
.open
->round
);
2186 WALK_SUBEXPR (co
->ext
.open
->sign
);
2187 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
2188 WALK_SUBEXPR (co
->ext
.open
->id
);
2189 WALK_SUBEXPR (co
->ext
.open
->newunit
);
2193 WALK_SUBEXPR (co
->ext
.close
->unit
);
2194 WALK_SUBEXPR (co
->ext
.close
->status
);
2195 WALK_SUBEXPR (co
->ext
.close
->iostat
);
2196 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
2199 case EXEC_BACKSPACE
:
2203 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
2204 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
2205 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
2209 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
2210 WALK_SUBEXPR (co
->ext
.inquire
->file
);
2211 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
2212 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
2213 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
2214 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
2215 WALK_SUBEXPR (co
->ext
.inquire
->number
);
2216 WALK_SUBEXPR (co
->ext
.inquire
->named
);
2217 WALK_SUBEXPR (co
->ext
.inquire
->name
);
2218 WALK_SUBEXPR (co
->ext
.inquire
->access
);
2219 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
2220 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
2221 WALK_SUBEXPR (co
->ext
.inquire
->form
);
2222 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
2223 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
2224 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
2225 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
2226 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
2227 WALK_SUBEXPR (co
->ext
.inquire
->position
);
2228 WALK_SUBEXPR (co
->ext
.inquire
->action
);
2229 WALK_SUBEXPR (co
->ext
.inquire
->read
);
2230 WALK_SUBEXPR (co
->ext
.inquire
->write
);
2231 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
2232 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
2233 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
2234 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
2235 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
2236 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
2237 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
2238 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
2239 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
2240 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
2241 WALK_SUBEXPR (co
->ext
.inquire
->id
);
2242 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
2243 WALK_SUBEXPR (co
->ext
.inquire
->size
);
2244 WALK_SUBEXPR (co
->ext
.inquire
->round
);
2248 WALK_SUBEXPR (co
->ext
.wait
->unit
);
2249 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
2250 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
2251 WALK_SUBEXPR (co
->ext
.wait
->id
);
2256 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
2257 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
2258 WALK_SUBEXPR (co
->ext
.dt
->rec
);
2259 WALK_SUBEXPR (co
->ext
.dt
->advance
);
2260 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
2261 WALK_SUBEXPR (co
->ext
.dt
->size
);
2262 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
2263 WALK_SUBEXPR (co
->ext
.dt
->id
);
2264 WALK_SUBEXPR (co
->ext
.dt
->pos
);
2265 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
2266 WALK_SUBEXPR (co
->ext
.dt
->blank
);
2267 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
2268 WALK_SUBEXPR (co
->ext
.dt
->delim
);
2269 WALK_SUBEXPR (co
->ext
.dt
->pad
);
2270 WALK_SUBEXPR (co
->ext
.dt
->round
);
2271 WALK_SUBEXPR (co
->ext
.dt
->sign
);
2272 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
2275 case EXEC_OMP_PARALLEL
:
2276 case EXEC_OMP_PARALLEL_DO
:
2277 case EXEC_OMP_PARALLEL_DO_SIMD
:
2278 case EXEC_OMP_PARALLEL_SECTIONS
:
2280 in_omp_workshare
= false;
2282 /* This goto serves as a shortcut to avoid code
2283 duplication or a larger if or switch statement. */
2284 goto check_omp_clauses
;
2286 case EXEC_OMP_WORKSHARE
:
2287 case EXEC_OMP_PARALLEL_WORKSHARE
:
2289 in_omp_workshare
= true;
2293 case EXEC_OMP_DISTRIBUTE
:
2294 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
2295 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2296 case EXEC_OMP_DISTRIBUTE_SIMD
:
2298 case EXEC_OMP_DO_SIMD
:
2299 case EXEC_OMP_SECTIONS
:
2300 case EXEC_OMP_SINGLE
:
2301 case EXEC_OMP_END_SINGLE
:
2303 case EXEC_OMP_TARGET
:
2304 case EXEC_OMP_TARGET_DATA
:
2305 case EXEC_OMP_TARGET_TEAMS
:
2306 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
2307 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2308 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2309 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2310 case EXEC_OMP_TARGET_UPDATE
:
2312 case EXEC_OMP_TEAMS
:
2313 case EXEC_OMP_TEAMS_DISTRIBUTE
:
2314 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2315 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2316 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
2318 /* Come to this label only from the
2319 EXEC_OMP_PARALLEL_* cases above. */
2323 if (co
->ext
.omp_clauses
)
2325 gfc_omp_namelist
*n
;
2326 static int list_types
[]
2327 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
2328 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
2330 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
2331 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
2332 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
2333 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
2334 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
2335 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
2336 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
2337 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
2338 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
2339 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
2341 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
2343 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
2345 WALK_SUBEXPR (n
->expr
);
2352 WALK_SUBEXPR (co
->expr1
);
2353 WALK_SUBEXPR (co
->expr2
);
2354 WALK_SUBEXPR (co
->expr3
);
2355 WALK_SUBEXPR (co
->expr4
);
2356 for (b
= co
->block
; b
; b
= b
->block
)
2358 WALK_SUBEXPR (b
->expr1
);
2359 WALK_SUBEXPR (b
->expr2
);
2360 WALK_SUBCODE (b
->next
);
2363 if (co
->op
== EXEC_FORALL
)
2366 if (co
->op
== EXEC_DO
)
2369 in_omp_workshare
= saved_in_omp_workshare
;