1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2016 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"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static void optimize_reduction (gfc_namespace
*);
43 static int callback_reduction (gfc_expr
**, int *, void *);
44 static void realloc_strings (gfc_namespace
*);
45 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
46 static int inline_matmul_assign (gfc_code
**, int *, void *);
47 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
48 locus
*, gfc_namespace
*,
51 /* How deep we are inside an argument list. */
53 static int count_arglist
;
55 /* Vector of gfc_expr ** we operate on. */
57 static vec
<gfc_expr
**> expr_array
;
59 /* Pointer to the gfc_code we currently work on - to be able to insert
60 a block before the statement. */
62 static gfc_code
**current_code
;
64 /* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
67 static gfc_code
*inserted_block
, **changed_statement
;
69 /* The namespace we are currently dealing with. */
71 static gfc_namespace
*current_ns
;
73 /* If we are within any forall loop. */
75 static int forall_level
;
77 /* Keep track of whether we are within an OMP workshare. */
79 static bool in_omp_workshare
;
81 /* Keep track of whether we are within a WHERE statement. */
85 /* Keep track of iterators for array constructors. */
87 static int iterator_level
;
89 /* Keep track of DO loop levels. */
91 static vec
<gfc_code
*> doloop_list
;
93 static int doloop_level
;
95 /* Vector of gfc_expr * to keep track of DO loops. */
97 struct my_struct
*evec
;
99 /* Keep track of association lists. */
101 static bool in_assoc_list
;
103 /* Counter for temporary variables. */
105 static int var_num
= 1;
107 /* What sort of matrix we are dealing with when inlining MATMUL. */
109 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
};
111 /* Keep track of the number of expressions we have inserted so far
116 /* Entry point - run all passes for a namespace. */
119 gfc_run_passes (gfc_namespace
*ns
)
122 /* Warn about dubious DO loops where the index might
127 doloop_list
.release ();
130 if (flag_frontend_optimize
)
132 optimize_namespace (ns
);
133 optimize_reduction (ns
);
134 if (flag_dump_fortran_optimized
)
135 gfc_dump_parse_tree (ns
, stdout
);
137 expr_array
.release ();
140 gfc_get_errors (&w
, &e
);
144 if (flag_realloc_lhs
)
145 realloc_strings (ns
);
148 /* Callback for each gfc_code node invoked from check_realloc_strings.
149 For an allocatable LHS string which also appears as a variable on
161 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
162 void *data ATTRIBUTE_UNUSED
)
164 gfc_expr
*expr1
, *expr2
;
168 if (co
->op
!= EXEC_ASSIGN
)
172 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
173 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
176 expr2
= gfc_discard_nops (co
->expr2
);
177 if (expr2
->expr_type
!= EXPR_VARIABLE
)
180 if (!gfc_check_dependency (expr1
, expr2
, true))
183 /* gfc_check_dependency doesn't always pick up identical expressions.
184 However, eliminating the above sends the compiler into an infinite
185 loop on valid expressions. Without this check, the gimplifier emits
186 an ICE for a = a, where a is deferred character length. */
187 if (!gfc_dep_compare_expr (expr1
, expr2
))
191 inserted_block
= NULL
;
192 changed_statement
= NULL
;
193 n
= create_var (expr2
, "trim");
198 /* Callback for each gfc_code node invoked through gfc_code_walker
199 from optimize_namespace. */
202 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
203 void *data ATTRIBUTE_UNUSED
)
210 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
211 || op
== EXEC_CALL_PPC
)
217 inserted_block
= NULL
;
218 changed_statement
= NULL
;
220 if (op
== EXEC_ASSIGN
)
221 optimize_assignment (*c
);
225 /* Callback for each gfc_expr node invoked through gfc_code_walker
226 from optimize_namespace. */
229 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
230 void *data ATTRIBUTE_UNUSED
)
234 if ((*e
)->expr_type
== EXPR_FUNCTION
)
237 function_expr
= true;
240 function_expr
= false;
242 if (optimize_trim (*e
))
243 gfc_simplify_expr (*e
, 0);
245 if (optimize_lexical_comparison (*e
))
246 gfc_simplify_expr (*e
, 0);
248 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
249 gfc_simplify_expr (*e
, 0);
251 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
252 switch ((*e
)->value
.function
.isym
->id
)
254 case GFC_ISYM_MINLOC
:
255 case GFC_ISYM_MAXLOC
:
256 optimize_minmaxloc (e
);
268 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
269 function is a scalar, just copy it; otherwise returns the new element, the
270 old one can be freed. */
273 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
275 gfc_expr
*fcn
, *e
= c
->expr
;
277 fcn
= gfc_copy_expr (e
);
280 gfc_constructor_base newbase
;
282 gfc_constructor
*new_c
;
285 new_expr
= gfc_get_expr ();
286 new_expr
->expr_type
= EXPR_ARRAY
;
287 new_expr
->ts
= e
->ts
;
288 new_expr
->where
= e
->where
;
290 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
291 new_c
->iterator
= c
->iterator
;
292 new_expr
->value
.constructor
= newbase
;
300 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
302 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
303 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
304 fn
->value
.function
.isym
->name
,
305 fn
->where
, 3, fcn
, NULL
, NULL
);
306 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
307 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
308 fn
->value
.function
.isym
->name
,
309 fn
->where
, 2, fcn
, NULL
);
311 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
313 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
319 /* Callback function for optimzation of reductions to scalars. Transform ANY
320 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
321 correspondingly. Handly only the simple cases without MASK and DIM. */
324 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
325 void *data ATTRIBUTE_UNUSED
)
330 gfc_actual_arglist
*a
;
331 gfc_actual_arglist
*dim
;
333 gfc_expr
*res
, *new_expr
;
334 gfc_actual_arglist
*mask
;
338 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
339 || fn
->value
.function
.isym
== NULL
)
342 id
= fn
->value
.function
.isym
->id
;
344 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
345 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
348 a
= fn
->value
.function
.actual
;
350 /* Don't handle MASK or DIM. */
354 if (dim
->expr
!= NULL
)
357 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
360 if ( mask
->expr
!= NULL
)
366 if (arg
->expr_type
!= EXPR_ARRAY
)
375 case GFC_ISYM_PRODUCT
:
376 op
= INTRINSIC_TIMES
;
391 c
= gfc_constructor_first (arg
->value
.constructor
);
393 /* Don't do any simplififcation if we have
394 - no element in the constructor or
395 - only have a single element in the array which contains an
401 res
= copy_walk_reduction_arg (c
, fn
);
403 c
= gfc_constructor_next (c
);
406 new_expr
= gfc_get_expr ();
407 new_expr
->ts
= fn
->ts
;
408 new_expr
->expr_type
= EXPR_OP
;
409 new_expr
->rank
= fn
->rank
;
410 new_expr
->where
= fn
->where
;
411 new_expr
->value
.op
.op
= op
;
412 new_expr
->value
.op
.op1
= res
;
413 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
415 c
= gfc_constructor_next (c
);
418 gfc_simplify_expr (res
, 0);
425 /* Callback function for common function elimination, called from cfe_expr_0.
426 Put all eligible function expressions into expr_array. */
429 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
430 void *data ATTRIBUTE_UNUSED
)
433 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
436 /* We don't do character functions with unknown charlens. */
437 if ((*e
)->ts
.type
== BT_CHARACTER
438 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
439 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
442 /* We don't do function elimination within FORALL statements, it can
443 lead to wrong-code in certain circumstances. */
445 if (forall_level
> 0)
448 /* Function elimination inside an iterator could lead to functions which
449 depend on iterator variables being moved outside. FIXME: We should check
450 if the functions do indeed depend on the iterator variable. */
452 if (iterator_level
> 0)
455 /* If we don't know the shape at compile time, we create an allocatable
456 temporary variable to hold the intermediate result, but only if
457 allocation on assignment is active. */
459 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
462 /* Skip the test for pure functions if -faggressive-function-elimination
464 if ((*e
)->value
.function
.esym
)
466 /* Don't create an array temporary for elemental functions. */
467 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
470 /* Only eliminate potentially impure functions if the
471 user specifically requested it. */
472 if (!flag_aggressive_function_elimination
473 && !(*e
)->value
.function
.esym
->attr
.pure
474 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
478 if ((*e
)->value
.function
.isym
)
480 /* Conversions are handled on the fly by the middle end,
481 transpose during trans-* stages and TRANSFER by the middle end. */
482 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
483 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
484 || gfc_inline_intrinsic_function_p (*e
))
487 /* Don't create an array temporary for elemental functions,
488 as this would be wasteful of memory.
489 FIXME: Create a scalar temporary during scalarization. */
490 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
493 if (!(*e
)->value
.function
.isym
->pure
)
497 expr_array
.safe_push (e
);
501 /* Auxiliary function to check if an expression is a temporary created by
505 is_fe_temp (gfc_expr
*e
)
507 if (e
->expr_type
!= EXPR_VARIABLE
)
510 return e
->symtree
->n
.sym
->attr
.fe_temp
;
513 /* Determine the length of a string, if it can be evaluated as a constant
514 expression. Return a newly allocated gfc_expr or NULL on failure.
515 If the user specified a substring which is potentially longer than
516 the string itself, the string will be padded with spaces, which
520 constant_string_length (gfc_expr
*e
)
530 length
= e
->ts
.u
.cl
->length
;
531 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
532 return gfc_copy_expr(length
);
535 /* Return length of substring, if constant. */
536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
538 if (ref
->type
== REF_SUBSTRING
539 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
541 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
544 mpz_add_ui (res
->value
.integer
, value
, 1);
550 /* Return length of char symbol, if constant. */
552 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
553 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
554 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
560 /* Insert a block at the current position unless it has already
561 been inserted; in this case use the one already there. */
563 static gfc_namespace
*
568 /* If the block hasn't already been created, do so. */
569 if (inserted_block
== NULL
)
571 inserted_block
= XCNEW (gfc_code
);
572 inserted_block
->op
= EXEC_BLOCK
;
573 inserted_block
->loc
= (*current_code
)->loc
;
574 ns
= gfc_build_block_ns (current_ns
);
575 inserted_block
->ext
.block
.ns
= ns
;
576 inserted_block
->ext
.block
.assoc
= NULL
;
578 ns
->code
= *current_code
;
580 /* If the statement has a label, make sure it is transferred to
581 the newly created block. */
583 if ((*current_code
)->here
)
585 inserted_block
->here
= (*current_code
)->here
;
586 (*current_code
)->here
= NULL
;
589 inserted_block
->next
= (*current_code
)->next
;
590 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
591 (*current_code
)->next
= NULL
;
592 /* Insert the BLOCK at the right position. */
593 *current_code
= inserted_block
;
594 ns
->parent
= current_ns
;
597 ns
= inserted_block
->ext
.block
.ns
;
602 /* Returns a new expression (a variable) to be used in place of the old one,
603 with an optional assignment statement before the current statement to set
604 the value of the variable. Creates a new BLOCK for the statement if that
605 hasn't already been done and puts the statement, plus the newly created
606 variables, in that block. Special cases: If the expression is constant or
607 a temporary which has already been created, just copy it. */
610 create_var (gfc_expr
* e
, const char *vname
)
612 char name
[GFC_MAX_SYMBOL_LEN
+1];
613 gfc_symtree
*symtree
;
621 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
622 return gfc_copy_expr (e
);
624 ns
= insert_block ();
627 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
629 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
631 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
634 symbol
= symtree
->n
.sym
;
639 symbol
->as
= gfc_get_array_spec ();
640 symbol
->as
->rank
= e
->rank
;
642 if (e
->shape
== NULL
)
644 /* We don't know the shape at compile time, so we use an
646 symbol
->as
->type
= AS_DEFERRED
;
647 symbol
->attr
.allocatable
= 1;
651 symbol
->as
->type
= AS_EXPLICIT
;
652 /* Copy the shape. */
653 for (i
=0; i
<e
->rank
; i
++)
657 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
659 mpz_set_si (p
->value
.integer
, 1);
660 symbol
->as
->lower
[i
] = p
;
662 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
664 mpz_set (q
->value
.integer
, e
->shape
[i
]);
665 symbol
->as
->upper
[i
] = q
;
671 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
675 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
676 length
= constant_string_length (e
);
678 symbol
->ts
.u
.cl
->length
= length
;
681 symbol
->attr
.allocatable
= 1;
686 symbol
->attr
.flavor
= FL_VARIABLE
;
687 symbol
->attr
.referenced
= 1;
688 symbol
->attr
.dimension
= e
->rank
> 0;
689 symbol
->attr
.fe_temp
= 1;
690 gfc_commit_symbol (symbol
);
692 result
= gfc_get_expr ();
693 result
->expr_type
= EXPR_VARIABLE
;
695 result
->ts
.deferred
= deferred
;
696 result
->rank
= e
->rank
;
697 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
698 result
->symtree
= symtree
;
699 result
->where
= e
->where
;
702 result
->ref
= gfc_get_ref ();
703 result
->ref
->type
= REF_ARRAY
;
704 result
->ref
->u
.ar
.type
= AR_FULL
;
705 result
->ref
->u
.ar
.where
= e
->where
;
706 result
->ref
->u
.ar
.dimen
= e
->rank
;
707 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
708 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
709 if (warn_array_temporaries
)
710 gfc_warning (OPT_Warray_temporaries
,
711 "Creating array temporary at %L", &(e
->where
));
714 /* Generate the new assignment. */
715 n
= XCNEW (gfc_code
);
717 n
->loc
= (*current_code
)->loc
;
718 n
->next
= *changed_statement
;
719 n
->expr1
= gfc_copy_expr (result
);
721 *changed_statement
= n
;
727 /* Warn about function elimination. */
730 do_warn_function_elimination (gfc_expr
*e
)
732 if (e
->expr_type
!= EXPR_FUNCTION
)
734 if (e
->value
.function
.esym
)
735 gfc_warning (0, "Removing call to function %qs at %L",
736 e
->value
.function
.esym
->name
, &(e
->where
));
737 else if (e
->value
.function
.isym
)
738 gfc_warning (0, "Removing call to function %qs at %L",
739 e
->value
.function
.isym
->name
, &(e
->where
));
741 /* Callback function for the code walker for doing common function
742 elimination. This builds up the list of functions in the expression
743 and goes through them to detect duplicates, which it then replaces
747 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
748 void *data ATTRIBUTE_UNUSED
)
754 /* Don't do this optimization within OMP workshare or ASSOC lists. */
756 if (in_omp_workshare
|| in_assoc_list
)
762 expr_array
.release ();
764 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
766 /* Walk through all the functions. */
768 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
770 /* Skip if the function has been replaced by a variable already. */
771 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
778 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
781 newvar
= create_var (*ei
, "fcn");
783 if (warn_function_elimination
)
784 do_warn_function_elimination (*ej
);
787 *ej
= gfc_copy_expr (newvar
);
794 /* We did all the necessary walking in this function. */
799 /* Callback function for common function elimination, called from
800 gfc_code_walker. This keeps track of the current code, in order
801 to insert statements as needed. */
804 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
807 inserted_block
= NULL
;
808 changed_statement
= NULL
;
810 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
811 and allocation on assigment are prohibited inside WHERE, and finally
812 masking an expression would lead to wrong-code when replacing
815 b = sum(foo(a) + foo(a))
826 if ((*c
)->op
== EXEC_WHERE
)
836 /* Dummy function for expression call back, for use when we
837 really don't want to do any walking. */
840 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
841 void *data ATTRIBUTE_UNUSED
)
847 /* Dummy function for code callback, for use when we really
848 don't want to do anything. */
850 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
851 int *walk_subtrees ATTRIBUTE_UNUSED
,
852 void *data ATTRIBUTE_UNUSED
)
857 /* Code callback function for converting
864 This is because common function elimination would otherwise place the
865 temporary variables outside the loop. */
868 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
869 void *data ATTRIBUTE_UNUSED
)
872 gfc_code
*c_if1
, *c_if2
, *c_exit
;
874 gfc_expr
*e_not
, *e_cond
;
876 if (co
->op
!= EXEC_DO_WHILE
)
879 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
884 /* Generate the condition of the if statement, which is .not. the original
886 e_not
= gfc_get_expr ();
887 e_not
->ts
= e_cond
->ts
;
888 e_not
->where
= e_cond
->where
;
889 e_not
->expr_type
= EXPR_OP
;
890 e_not
->value
.op
.op
= INTRINSIC_NOT
;
891 e_not
->value
.op
.op1
= e_cond
;
893 /* Generate the EXIT statement. */
894 c_exit
= XCNEW (gfc_code
);
895 c_exit
->op
= EXEC_EXIT
;
896 c_exit
->ext
.which_construct
= co
;
897 c_exit
->loc
= co
->loc
;
899 /* Generate the IF statement. */
900 c_if2
= XCNEW (gfc_code
);
902 c_if2
->expr1
= e_not
;
903 c_if2
->next
= c_exit
;
904 c_if2
->loc
= co
->loc
;
906 /* ... plus the one to chain it to. */
907 c_if1
= XCNEW (gfc_code
);
909 c_if1
->block
= c_if2
;
910 c_if1
->loc
= co
->loc
;
912 /* Make the DO WHILE loop into a DO block by replacing the condition
913 with a true constant. */
914 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
916 /* Hang the generated if statement into the loop body. */
918 loopblock
= co
->block
->next
;
919 co
->block
->next
= c_if1
;
920 c_if1
->next
= loopblock
;
925 /* Code callback function for converting
938 because otherwise common function elimination would place the BLOCKs
939 into the wrong place. */
942 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
943 void *data ATTRIBUTE_UNUSED
)
946 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
948 if (co
->op
!= EXEC_IF
)
951 /* This loop starts out with the first ELSE statement. */
952 else_stmt
= co
->block
->block
;
954 while (else_stmt
!= NULL
)
958 /* If there is no condition, we're done. */
959 if (else_stmt
->expr1
== NULL
)
962 next_else
= else_stmt
->block
;
964 /* Generate the new IF statement. */
965 c_if2
= XCNEW (gfc_code
);
967 c_if2
->expr1
= else_stmt
->expr1
;
968 c_if2
->next
= else_stmt
->next
;
969 c_if2
->loc
= else_stmt
->loc
;
970 c_if2
->block
= next_else
;
972 /* ... plus the one to chain it to. */
973 c_if1
= XCNEW (gfc_code
);
975 c_if1
->block
= c_if2
;
976 c_if1
->loc
= else_stmt
->loc
;
978 /* Insert the new IF after the ELSE. */
979 else_stmt
->expr1
= NULL
;
980 else_stmt
->next
= c_if1
;
981 else_stmt
->block
= NULL
;
983 else_stmt
= next_else
;
985 /* Don't walk subtrees. */
989 /* Optimize a namespace, including all contained namespaces. */
992 optimize_namespace (gfc_namespace
*ns
)
994 gfc_namespace
*saved_ns
= gfc_current_ns
;
999 in_assoc_list
= false;
1000 in_omp_workshare
= false;
1002 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1003 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1004 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1005 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1006 if (flag_inline_matmul_limit
!= 0)
1007 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1010 /* BLOCKs are handled in the expression walker below. */
1011 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1013 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1014 optimize_namespace (ns
);
1016 gfc_current_ns
= saved_ns
;
1019 /* Handle dependencies for allocatable strings which potentially redefine
1020 themselves in an assignment. */
1023 realloc_strings (gfc_namespace
*ns
)
1026 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1028 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1030 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1031 realloc_strings (ns
);
1037 optimize_reduction (gfc_namespace
*ns
)
1040 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1041 callback_reduction
, NULL
);
1043 /* BLOCKs are handled in the expression walker below. */
1044 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1046 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1047 optimize_reduction (ns
);
1051 /* Replace code like
1054 a = matmul(b,c) ; a = a + d
1055 where the array function is not elemental and not allocatable
1056 and does not depend on the left-hand side.
1060 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1065 if (e
->expr_type
== EXPR_OP
)
1067 switch (e
->value
.op
.op
)
1069 /* Unary operators and exponentiation: Only look at a single
1072 case INTRINSIC_UPLUS
:
1073 case INTRINSIC_UMINUS
:
1074 case INTRINSIC_PARENTHESES
:
1075 case INTRINSIC_POWER
:
1076 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1080 case INTRINSIC_CONCAT
:
1081 /* Do not do string concatenations. */
1085 /* Binary operators. */
1086 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1089 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1095 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1096 && ! (e
->value
.function
.esym
1097 && (e
->value
.function
.esym
->attr
.elemental
1098 || e
->value
.function
.esym
->attr
.allocatable
1099 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1100 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1101 && ! (e
->value
.function
.isym
1102 && (e
->value
.function
.isym
->elemental
1103 || e
->ts
.type
!= c
->expr1
->ts
.type
1104 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1105 && ! gfc_inline_intrinsic_function_p (e
))
1111 /* Insert a new assignment statement after the current one. */
1112 n
= XCNEW (gfc_code
);
1113 n
->op
= EXEC_ASSIGN
;
1118 n
->expr1
= gfc_copy_expr (c
->expr1
);
1119 n
->expr2
= c
->expr2
;
1120 new_expr
= gfc_copy_expr (c
->expr1
);
1128 /* Nothing to optimize. */
1132 /* Remove unneeded TRIMs at the end of expressions. */
1135 remove_trim (gfc_expr
*rhs
)
1143 /* Check for a // b // trim(c). Looping is probably not
1144 necessary because the parser usually generates
1145 (// (// a b ) trim(c) ) , but better safe than sorry. */
1147 while (rhs
->expr_type
== EXPR_OP
1148 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1149 rhs
= rhs
->value
.op
.op2
;
1151 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1152 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1154 strip_function_call (rhs
);
1155 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1163 /* Optimizations for an assignment. */
1166 optimize_assignment (gfc_code
* c
)
1168 gfc_expr
*lhs
, *rhs
;
1173 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1175 /* Optimize a = trim(b) to a = b. */
1178 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1179 if (is_empty_string (rhs
))
1180 rhs
->value
.character
.length
= 0;
1183 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1184 optimize_binop_array_assignment (c
, &rhs
, false);
1188 /* Remove an unneeded function call, modifying the expression.
1189 This replaces the function call with the value of its
1190 first argument. The rest of the argument list is freed. */
1193 strip_function_call (gfc_expr
*e
)
1196 gfc_actual_arglist
*a
;
1198 a
= e
->value
.function
.actual
;
1200 /* We should have at least one argument. */
1201 gcc_assert (a
->expr
!= NULL
);
1205 /* Free the remaining arglist, if any. */
1207 gfc_free_actual_arglist (a
->next
);
1209 /* Graft the argument expression onto the original function. */
1215 /* Optimization of lexical comparison functions. */
1218 optimize_lexical_comparison (gfc_expr
*e
)
1220 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1223 switch (e
->value
.function
.isym
->id
)
1226 return optimize_comparison (e
, INTRINSIC_LE
);
1229 return optimize_comparison (e
, INTRINSIC_GE
);
1232 return optimize_comparison (e
, INTRINSIC_GT
);
1235 return optimize_comparison (e
, INTRINSIC_LT
);
1243 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1244 do CHARACTER because of possible pessimization involving character
1248 combine_array_constructor (gfc_expr
*e
)
1251 gfc_expr
*op1
, *op2
;
1254 gfc_constructor
*c
, *new_c
;
1255 gfc_constructor_base oldbase
, newbase
;
1258 /* Array constructors have rank one. */
1262 /* Don't try to combine association lists, this makes no sense
1263 and leads to an ICE. */
1267 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1268 if (forall_level
> 0)
1271 /* Inside an iterator, things can get hairy; we are likely to create
1272 an invalid temporary variable. */
1273 if (iterator_level
> 0)
1276 op1
= e
->value
.op
.op1
;
1277 op2
= e
->value
.op
.op2
;
1282 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1283 scalar_first
= false;
1284 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1286 scalar_first
= true;
1287 op1
= e
->value
.op
.op2
;
1288 op2
= e
->value
.op
.op1
;
1293 if (op2
->ts
.type
== BT_CHARACTER
)
1296 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1298 oldbase
= op1
->value
.constructor
;
1300 e
->expr_type
= EXPR_ARRAY
;
1302 for (c
= gfc_constructor_first (oldbase
); c
;
1303 c
= gfc_constructor_next (c
))
1305 new_expr
= gfc_get_expr ();
1306 new_expr
->ts
= e
->ts
;
1307 new_expr
->expr_type
= EXPR_OP
;
1308 new_expr
->rank
= c
->expr
->rank
;
1309 new_expr
->where
= c
->where
;
1310 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1314 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1315 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1319 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1320 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1323 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1324 new_c
->iterator
= c
->iterator
;
1328 gfc_free_expr (op1
);
1329 gfc_free_expr (op2
);
1330 gfc_free_expr (scalar
);
1332 e
->value
.constructor
= newbase
;
1336 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1337 2**k into ishift(1,k) */
1340 optimize_power (gfc_expr
*e
)
1342 gfc_expr
*op1
, *op2
;
1343 gfc_expr
*iand
, *ishft
;
1345 if (e
->ts
.type
!= BT_INTEGER
)
1348 op1
= e
->value
.op
.op1
;
1350 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1353 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1355 gfc_free_expr (op1
);
1357 op2
= e
->value
.op
.op2
;
1362 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1363 "_internal_iand", e
->where
, 2, op2
,
1364 gfc_get_int_expr (e
->ts
.kind
,
1367 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1368 "_internal_ishft", e
->where
, 2, iand
,
1369 gfc_get_int_expr (e
->ts
.kind
,
1372 e
->value
.op
.op
= INTRINSIC_MINUS
;
1373 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1374 e
->value
.op
.op2
= ishft
;
1377 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1379 gfc_free_expr (op1
);
1381 op2
= e
->value
.op
.op2
;
1385 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1386 "_internal_ishft", e
->where
, 2,
1387 gfc_get_int_expr (e
->ts
.kind
,
1394 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1396 op2
= e
->value
.op
.op2
;
1400 gfc_free_expr (op1
);
1401 gfc_free_expr (op2
);
1403 e
->expr_type
= EXPR_CONSTANT
;
1404 e
->value
.op
.op1
= NULL
;
1405 e
->value
.op
.op2
= NULL
;
1406 mpz_init_set_si (e
->value
.integer
, 1);
1407 /* Typespec and location are still OK. */
1414 /* Recursive optimization of operators. */
1417 optimize_op (gfc_expr
*e
)
1421 gfc_intrinsic_op op
= e
->value
.op
.op
;
1425 /* Only use new-style comparisons. */
1428 case INTRINSIC_EQ_OS
:
1432 case INTRINSIC_GE_OS
:
1436 case INTRINSIC_LE_OS
:
1440 case INTRINSIC_NE_OS
:
1444 case INTRINSIC_GT_OS
:
1448 case INTRINSIC_LT_OS
:
1464 changed
= optimize_comparison (e
, op
);
1467 /* Look at array constructors. */
1468 case INTRINSIC_PLUS
:
1469 case INTRINSIC_MINUS
:
1470 case INTRINSIC_TIMES
:
1471 case INTRINSIC_DIVIDE
:
1472 return combine_array_constructor (e
) || changed
;
1474 case INTRINSIC_POWER
:
1475 return optimize_power (e
);
1486 /* Return true if a constant string contains only blanks. */
1489 is_empty_string (gfc_expr
*e
)
1493 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1496 for (i
=0; i
< e
->value
.character
.length
; i
++)
1498 if (e
->value
.character
.string
[i
] != ' ')
1506 /* Insert a call to the intrinsic len_trim. Use a different name for
1507 the symbol tree so we don't run into trouble when the user has
1508 renamed len_trim for some reason. */
1511 get_len_trim_call (gfc_expr
*str
, int kind
)
1514 gfc_actual_arglist
*actual_arglist
, *next
;
1516 fcn
= gfc_get_expr ();
1517 fcn
->expr_type
= EXPR_FUNCTION
;
1518 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1519 actual_arglist
= gfc_get_actual_arglist ();
1520 actual_arglist
->expr
= str
;
1521 next
= gfc_get_actual_arglist ();
1522 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1523 actual_arglist
->next
= next
;
1525 fcn
->value
.function
.actual
= actual_arglist
;
1526 fcn
->where
= str
->where
;
1527 fcn
->ts
.type
= BT_INTEGER
;
1528 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1530 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1531 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1532 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1533 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1534 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1535 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1536 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1537 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1542 /* Optimize expressions for equality. */
1545 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1547 gfc_expr
*op1
, *op2
;
1551 gfc_actual_arglist
*firstarg
, *secondarg
;
1553 if (e
->expr_type
== EXPR_OP
)
1557 op1
= e
->value
.op
.op1
;
1558 op2
= e
->value
.op
.op2
;
1560 else if (e
->expr_type
== EXPR_FUNCTION
)
1562 /* One of the lexical comparison functions. */
1563 firstarg
= e
->value
.function
.actual
;
1564 secondarg
= firstarg
->next
;
1565 op1
= firstarg
->expr
;
1566 op2
= secondarg
->expr
;
1571 /* Strip off unneeded TRIM calls from string comparisons. */
1573 change
= remove_trim (op1
);
1575 if (remove_trim (op2
))
1578 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1579 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1580 handles them well). However, there are also cases that need a non-scalar
1581 argument. For example the any intrinsic. See PR 45380. */
1585 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1587 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1588 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1590 bool empty_op1
, empty_op2
;
1591 empty_op1
= is_empty_string (op1
);
1592 empty_op2
= is_empty_string (op2
);
1594 if (empty_op1
|| empty_op2
)
1600 /* This can only happen when an error for comparing
1601 characters of different kinds has already been issued. */
1602 if (empty_op1
&& empty_op2
)
1605 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1606 str
= empty_op1
? op2
: op1
;
1608 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1612 gfc_free_expr (op1
);
1614 gfc_free_expr (op2
);
1618 e
->value
.op
.op1
= fcn
;
1619 e
->value
.op
.op2
= zero
;
1624 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1626 if (flag_finite_math_only
1627 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1628 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1630 eq
= gfc_dep_compare_expr (op1
, op2
);
1633 /* Replace A // B < A // C with B < C, and A // B < C // B
1635 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1636 && op1
->expr_type
== EXPR_OP
1637 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1638 && op2
->expr_type
== EXPR_OP
1639 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1641 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1642 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1643 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1644 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1646 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1648 /* Watch out for 'A ' // x vs. 'A' // x. */
1650 if (op1_left
->expr_type
== EXPR_CONSTANT
1651 && op2_left
->expr_type
== EXPR_CONSTANT
1652 && op1_left
->value
.character
.length
1653 != op2_left
->value
.character
.length
)
1661 firstarg
->expr
= op1_right
;
1662 secondarg
->expr
= op2_right
;
1666 e
->value
.op
.op1
= op1_right
;
1667 e
->value
.op
.op2
= op2_right
;
1669 optimize_comparison (e
, op
);
1673 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1679 firstarg
->expr
= op1_left
;
1680 secondarg
->expr
= op2_left
;
1684 e
->value
.op
.op1
= op1_left
;
1685 e
->value
.op
.op2
= op2_left
;
1688 optimize_comparison (e
, op
);
1695 /* eq can only be -1, 0 or 1 at this point. */
1723 gfc_internal_error ("illegal OP in optimize_comparison");
1727 /* Replace the expression by a constant expression. The typespec
1728 and where remains the way it is. */
1731 e
->expr_type
= EXPR_CONSTANT
;
1732 e
->value
.logical
= result
;
1740 /* Optimize a trim function by replacing it with an equivalent substring
1741 involving a call to len_trim. This only works for expressions where
1742 variables are trimmed. Return true if anything was modified. */
1745 optimize_trim (gfc_expr
*e
)
1750 gfc_ref
**rr
= NULL
;
1752 /* Don't do this optimization within an argument list, because
1753 otherwise aliasing issues may occur. */
1755 if (count_arglist
!= 1)
1758 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1759 || e
->value
.function
.isym
== NULL
1760 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1763 a
= e
->value
.function
.actual
->expr
;
1765 if (a
->expr_type
!= EXPR_VARIABLE
)
1768 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1770 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1773 /* Follow all references to find the correct place to put the newly
1774 created reference. FIXME: Also handle substring references and
1775 array references. Array references cause strange regressions at
1780 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1782 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1787 strip_function_call (e
);
1792 /* Create the reference. */
1794 ref
= gfc_get_ref ();
1795 ref
->type
= REF_SUBSTRING
;
1797 /* Set the start of the reference. */
1799 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1801 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1803 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1805 /* Set the end of the reference to the call to len_trim. */
1807 ref
->u
.ss
.end
= fcn
;
1808 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1813 /* Optimize minloc(b), where b is rank 1 array, into
1814 (/ minloc(b, dim=1) /), and similarly for maxloc,
1815 as the latter forms are expanded inline. */
1818 optimize_minmaxloc (gfc_expr
**e
)
1821 gfc_actual_arglist
*a
;
1825 || fn
->value
.function
.actual
== NULL
1826 || fn
->value
.function
.actual
->expr
== NULL
1827 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1830 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1831 (*e
)->shape
= fn
->shape
;
1834 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1836 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1837 strcpy (name
, fn
->value
.function
.name
);
1838 p
= strstr (name
, "loc0");
1840 fn
->value
.function
.name
= gfc_get_string (name
);
1841 if (fn
->value
.function
.actual
->next
)
1843 a
= fn
->value
.function
.actual
->next
;
1844 gcc_assert (a
->expr
== NULL
);
1848 a
= gfc_get_actual_arglist ();
1849 fn
->value
.function
.actual
->next
= a
;
1851 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1853 mpz_set_ui (a
->expr
->value
.integer
, 1);
1856 /* Callback function for code checking that we do not pass a DO variable to an
1857 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1860 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1861 void *data ATTRIBUTE_UNUSED
)
1865 gfc_formal_arglist
*f
;
1866 gfc_actual_arglist
*a
;
1871 /* If the doloop_list grew, we have to truncate it here. */
1873 if ((unsigned) doloop_level
< doloop_list
.length())
1874 doloop_list
.truncate (doloop_level
);
1880 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1881 doloop_list
.safe_push (co
);
1883 doloop_list
.safe_push ((gfc_code
*) NULL
);
1888 if (co
->resolved_sym
== NULL
)
1891 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1893 /* Withot a formal arglist, there is only unknown INTENT,
1894 which we don't check for. */
1902 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1909 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1911 if (a
->expr
&& a
->expr
->symtree
1912 && a
->expr
->symtree
->n
.sym
== do_sym
)
1914 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1915 gfc_error_now ("Variable %qs at %L set to undefined "
1916 "value inside loop beginning at %L as "
1917 "INTENT(OUT) argument to subroutine %qs",
1918 do_sym
->name
, &a
->expr
->where
,
1919 &doloop_list
[i
]->loc
,
1920 co
->symtree
->n
.sym
->name
);
1921 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1922 gfc_error_now ("Variable %qs at %L not definable inside "
1923 "loop beginning at %L as INTENT(INOUT) "
1924 "argument to subroutine %qs",
1925 do_sym
->name
, &a
->expr
->where
,
1926 &doloop_list
[i
]->loc
,
1927 co
->symtree
->n
.sym
->name
);
1941 /* Callback function for functions checking that we do not pass a DO variable
1942 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1945 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1946 void *data ATTRIBUTE_UNUSED
)
1948 gfc_formal_arglist
*f
;
1949 gfc_actual_arglist
*a
;
1955 if (expr
->expr_type
!= EXPR_FUNCTION
)
1958 /* Intrinsic functions don't modify their arguments. */
1960 if (expr
->value
.function
.isym
)
1963 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1965 /* Without a formal arglist, there is only unknown INTENT,
1966 which we don't check for. */
1970 a
= expr
->value
.function
.actual
;
1974 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1981 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1983 if (a
->expr
&& a
->expr
->symtree
1984 && a
->expr
->symtree
->n
.sym
== do_sym
)
1986 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1987 gfc_error_now ("Variable %qs at %L set to undefined value "
1988 "inside loop beginning at %L as INTENT(OUT) "
1989 "argument to function %qs", do_sym
->name
,
1990 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1991 expr
->symtree
->n
.sym
->name
);
1992 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1993 gfc_error_now ("Variable %qs at %L not definable inside loop"
1994 " beginning at %L as INTENT(INOUT) argument to"
1995 " function %qs", do_sym
->name
,
1996 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1997 expr
->symtree
->n
.sym
->name
);
2008 doloop_warn (gfc_namespace
*ns
)
2010 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2013 /* This selction deals with inlining calls to MATMUL. */
2015 /* Auxiliary function to build and simplify an array inquiry function.
2016 dim is zero-based. */
2019 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2022 gfc_expr
*dim_arg
, *kind
;
2028 case GFC_ISYM_LBOUND
:
2029 name
= "_gfortran_lbound";
2032 case GFC_ISYM_UBOUND
:
2033 name
= "_gfortran_ubound";
2037 name
= "_gfortran_size";
2044 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2045 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2046 gfc_index_integer_kind
);
2048 ec
= gfc_copy_expr (e
);
2049 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2051 gfc_simplify_expr (fcn
, 0);
2055 /* Builds a logical expression. */
2058 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2063 ts
.type
= BT_LOGICAL
;
2064 ts
.kind
= gfc_default_logical_kind
;
2065 res
= gfc_get_expr ();
2066 res
->where
= e1
->where
;
2067 res
->expr_type
= EXPR_OP
;
2068 res
->value
.op
.op
= op
;
2069 res
->value
.op
.op1
= e1
;
2070 res
->value
.op
.op2
= e2
;
2077 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2078 compatible typespecs. */
2081 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2085 res
= gfc_get_expr ();
2087 res
->where
= e1
->where
;
2088 res
->expr_type
= EXPR_OP
;
2089 res
->value
.op
.op
= op
;
2090 res
->value
.op
.op1
= e1
;
2091 res
->value
.op
.op2
= e2
;
2092 gfc_simplify_expr (res
, 0);
2096 /* Generate the IF statement for a runtime check if we want to do inlining or
2097 not - putting in the code for both branches and putting it into the syntax
2098 tree is the caller's responsibility. For fixed array sizes, this should be
2099 removed by DCE. Only called for rank-two matrices A and B. */
2102 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2104 gfc_expr
*inline_limit
;
2105 gfc_code
*if_1
, *if_2
, *else_2
;
2106 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2110 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2112 /* Calculation is done in real to avoid integer overflow. */
2114 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2116 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2118 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2121 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2122 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2123 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2127 ts
.kind
= gfc_default_real_kind
;
2128 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2129 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2130 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2132 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2133 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2135 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2136 gfc_simplify_expr (cond
, 0);
2138 else_2
= XCNEW (gfc_code
);
2139 else_2
->op
= EXEC_IF
;
2140 else_2
->loc
= a
->where
;
2142 if_2
= XCNEW (gfc_code
);
2145 if_2
->loc
= a
->where
;
2146 if_2
->block
= else_2
;
2148 if_1
= XCNEW (gfc_code
);
2151 if_1
->loc
= a
->where
;
2157 /* Insert code to issue a runtime error if the expressions are not equal. */
2160 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2163 gfc_code
*if_1
, *if_2
;
2165 gfc_actual_arglist
*a1
, *a2
, *a3
;
2167 gcc_assert (e1
->where
.lb
);
2168 /* Build the call to runtime_error. */
2169 c
= XCNEW (gfc_code
);
2173 /* Get a null-terminated message string. */
2175 a1
= gfc_get_actual_arglist ();
2176 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2177 msg
, strlen(msg
)+1);
2180 /* Pass the value of the first expression. */
2181 a2
= gfc_get_actual_arglist ();
2182 a2
->expr
= gfc_copy_expr (e1
);
2185 /* Pass the value of the second expression. */
2186 a3
= gfc_get_actual_arglist ();
2187 a3
->expr
= gfc_copy_expr (e2
);
2190 gfc_check_fe_runtime_error (c
->ext
.actual
);
2191 gfc_resolve_fe_runtime_error (c
);
2193 if_2
= XCNEW (gfc_code
);
2195 if_2
->loc
= e1
->where
;
2198 if_1
= XCNEW (gfc_code
);
2201 if_1
->loc
= e1
->where
;
2203 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2204 gfc_simplify_expr (cond
, 0);
2210 /* Handle matrix reallocation. Caller is responsible to insert into
2213 For the two-dimensional case, build
2215 if (allocated(c)) then
2216 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2218 allocate (c(size(a,1), size(b,2)))
2221 allocate (c(size(a,1),size(b,2)))
2224 and for the other cases correspondingly.
2228 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2229 enum matrix_case m_case
)
2232 gfc_expr
*allocated
, *alloc_expr
;
2233 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2234 gfc_code
*else_alloc
;
2235 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2237 gfc_expr
*cond
, *ne1
, *ne2
;
2239 if (warn_realloc_lhs
)
2240 gfc_warning (OPT_Wrealloc_lhs
,
2241 "Code for reallocating the allocatable array at %L will "
2242 "be added", &c
->where
);
2244 alloc_expr
= gfc_copy_expr (c
);
2246 ar
= gfc_find_array_ref (alloc_expr
);
2247 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2249 /* c comes in as a full ref. Change it into a copy and make it into an
2250 element ref so it has the right form for for ALLOCATE. In the same
2251 switch statement, also generate the size comparison for the secod IF
2254 ar
->type
= AR_ELEMENT
;
2259 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2260 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2261 ne1
= build_logical_expr (INTRINSIC_NE
,
2262 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2263 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2264 ne2
= build_logical_expr (INTRINSIC_NE
,
2265 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2266 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2267 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2271 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2272 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2274 ne1
= build_logical_expr (INTRINSIC_NE
,
2275 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2276 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2277 ne2
= build_logical_expr (INTRINSIC_NE
,
2278 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2279 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2280 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2284 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2285 cond
= build_logical_expr (INTRINSIC_NE
,
2286 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2287 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2291 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2292 cond
= build_logical_expr (INTRINSIC_NE
,
2293 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2294 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2302 gfc_simplify_expr (cond
, 0);
2304 /* We need two identical allocate statements in two
2305 branches of the IF statement. */
2307 allocate1
= XCNEW (gfc_code
);
2308 allocate1
->op
= EXEC_ALLOCATE
;
2309 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2310 allocate1
->loc
= c
->where
;
2311 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2313 allocate_else
= XCNEW (gfc_code
);
2314 allocate_else
->op
= EXEC_ALLOCATE
;
2315 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2316 allocate_else
->loc
= c
->where
;
2317 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2319 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2320 "_gfortran_allocated", c
->where
,
2321 1, gfc_copy_expr (c
));
2323 deallocate
= XCNEW (gfc_code
);
2324 deallocate
->op
= EXEC_DEALLOCATE
;
2325 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2326 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2327 deallocate
->next
= allocate1
;
2328 deallocate
->loc
= c
->where
;
2330 if_size_2
= XCNEW (gfc_code
);
2331 if_size_2
->op
= EXEC_IF
;
2332 if_size_2
->expr1
= cond
;
2333 if_size_2
->loc
= c
->where
;
2334 if_size_2
->next
= deallocate
;
2336 if_size_1
= XCNEW (gfc_code
);
2337 if_size_1
->op
= EXEC_IF
;
2338 if_size_1
->block
= if_size_2
;
2339 if_size_1
->loc
= c
->where
;
2341 else_alloc
= XCNEW (gfc_code
);
2342 else_alloc
->op
= EXEC_IF
;
2343 else_alloc
->loc
= c
->where
;
2344 else_alloc
->next
= allocate_else
;
2346 if_alloc_2
= XCNEW (gfc_code
);
2347 if_alloc_2
->op
= EXEC_IF
;
2348 if_alloc_2
->expr1
= allocated
;
2349 if_alloc_2
->loc
= c
->where
;
2350 if_alloc_2
->next
= if_size_1
;
2351 if_alloc_2
->block
= else_alloc
;
2353 if_alloc_1
= XCNEW (gfc_code
);
2354 if_alloc_1
->op
= EXEC_IF
;
2355 if_alloc_1
->block
= if_alloc_2
;
2356 if_alloc_1
->loc
= c
->where
;
2361 /* Callback function for has_function_or_op. */
2364 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2365 void *data ATTRIBUTE_UNUSED
)
2370 return (*e
)->expr_type
== EXPR_FUNCTION
2371 || (*e
)->expr_type
== EXPR_OP
;
2374 /* Returns true if the expression contains a function. */
2377 has_function_or_op (gfc_expr
**e
)
2382 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2385 /* Freeze (assign to a temporary variable) a single expression. */
2388 freeze_expr (gfc_expr
**ep
)
2391 if (has_function_or_op (ep
))
2393 ne
= create_var (*ep
, "freeze");
2398 /* Go through an expression's references and assign them to temporary
2399 variables if they contain functions. This is usually done prior to
2400 front-end scalarization to avoid multiple invocations of functions. */
2403 freeze_references (gfc_expr
*e
)
2409 for (r
=e
->ref
; r
; r
=r
->next
)
2411 if (r
->type
== REF_SUBSTRING
)
2413 if (r
->u
.ss
.start
!= NULL
)
2414 freeze_expr (&r
->u
.ss
.start
);
2416 if (r
->u
.ss
.end
!= NULL
)
2417 freeze_expr (&r
->u
.ss
.end
);
2419 else if (r
->type
== REF_ARRAY
)
2428 for (i
=0; i
<ar
->dimen
; i
++)
2430 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2432 freeze_expr (&ar
->start
[i
]);
2433 freeze_expr (&ar
->end
[i
]);
2434 freeze_expr (&ar
->stride
[i
]);
2436 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2438 freeze_expr (&ar
->start
[i
]);
2444 for (i
=0; i
<ar
->dimen
; i
++)
2445 freeze_expr (&ar
->start
[i
]);
2455 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2458 convert_to_index_kind (gfc_expr
*e
)
2462 gcc_assert (e
!= NULL
);
2464 res
= gfc_copy_expr (e
);
2466 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2468 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2472 ts
.type
= BT_INTEGER
;
2473 ts
.kind
= gfc_index_integer_kind
;
2475 gfc_convert_type_warn (e
, &ts
, 2, 0);
2481 /* Function to create a DO loop including creation of the
2482 iteration variable. gfc_expr are copied.*/
2485 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2486 gfc_namespace
*ns
, char *vname
)
2489 char name
[GFC_MAX_SYMBOL_LEN
+1];
2490 gfc_symtree
*symtree
;
2495 /* Create an expression for the iteration variable. */
2497 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2499 sprintf (name
, "__var_%d_do", var_num
++);
2502 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2505 /* Create the loop variable. */
2507 symbol
= symtree
->n
.sym
;
2508 symbol
->ts
.type
= BT_INTEGER
;
2509 symbol
->ts
.kind
= gfc_index_integer_kind
;
2510 symbol
->attr
.flavor
= FL_VARIABLE
;
2511 symbol
->attr
.referenced
= 1;
2512 symbol
->attr
.dimension
= 0;
2513 symbol
->attr
.fe_temp
= 1;
2514 gfc_commit_symbol (symbol
);
2516 i
= gfc_get_expr ();
2517 i
->expr_type
= EXPR_VARIABLE
;
2521 i
->symtree
= symtree
;
2523 /* ... and the nested DO statements. */
2524 n
= XCNEW (gfc_code
);
2527 n
->ext
.iterator
= gfc_get_iterator ();
2528 n
->ext
.iterator
->var
= i
;
2529 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2530 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2532 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2534 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2537 n2
= XCNEW (gfc_code
);
2545 /* Get the upper bound of the DO loops for matmul along a dimension. This
2549 get_size_m1 (gfc_expr
*e
, int dimen
)
2554 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2556 res
= gfc_get_constant_expr (BT_INTEGER
,
2557 gfc_index_integer_kind
, &e
->where
);
2558 mpz_sub_ui (res
->value
.integer
, size
, 1);
2563 res
= get_operand (INTRINSIC_MINUS
,
2564 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2565 gfc_get_int_expr (gfc_index_integer_kind
,
2567 gfc_simplify_expr (res
, 0);
2573 /* Function to return a scalarized expression. It is assumed that indices are
2574 zero based to make generation of DO loops easier. A zero as index will
2575 access the first element along a dimension. Single element references will
2576 be skipped. A NULL as an expression will be replaced by a full reference.
2577 This assumes that the index loops have gfc_index_integer_kind, and that all
2578 references have been frozen. */
2581 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2590 e
= gfc_copy_expr(e_in
);
2594 ar
= gfc_find_array_ref (e
);
2596 /* We scalarize count_index variables, reducing the rank by count_index. */
2598 e
->rank
= rank
- count_index
;
2600 was_fullref
= ar
->type
== AR_FULL
;
2603 ar
->type
= AR_ELEMENT
;
2605 ar
->type
= AR_SECTION
;
2607 /* Loop over the indices. For each index, create the expression
2608 index * stride + lbound(e, dim). */
2611 for (i
=0; i
< ar
->dimen
; i
++)
2613 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2615 if (index
[i_index
] != NULL
)
2617 gfc_expr
*lbound
, *nindex
;
2620 loopvar
= gfc_copy_expr (index
[i_index
]);
2626 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2627 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2631 ts
.type
= BT_INTEGER
;
2632 ts
.kind
= gfc_index_integer_kind
;
2633 gfc_convert_type (tmp
, &ts
, 2);
2635 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2640 /* Calculate the lower bound of the expression. */
2643 lbound
= gfc_copy_expr (ar
->start
[i
]);
2644 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2648 ts
.type
= BT_INTEGER
;
2649 ts
.kind
= gfc_index_integer_kind
;
2650 gfc_convert_type (lbound
, &ts
, 2);
2659 lbound_e
= gfc_copy_expr (e_in
);
2661 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2662 if (ref
->type
== REF_ARRAY
2663 && (ref
->u
.ar
.type
== AR_FULL
2664 || ref
->u
.ar
.type
== AR_SECTION
))
2669 gfc_free_ref_list (ref
->next
);
2675 /* Look at full individual sections, like a(:). The first index
2676 is the lbound of a full ref. */
2682 for (j
= 0; j
< ar
->dimen
; j
++)
2684 gfc_free_expr (ar
->start
[j
]);
2685 ar
->start
[j
] = NULL
;
2686 gfc_free_expr (ar
->end
[j
]);
2688 gfc_free_expr (ar
->stride
[j
]);
2689 ar
->stride
[j
] = NULL
;
2692 /* We have to get rid of the shape, if there is one. Do
2693 so by freeing it and calling gfc_resolve to rebuild
2694 it, if necessary. */
2696 if (lbound_e
->shape
)
2697 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2699 lbound_e
->rank
= ar
->dimen
;
2700 gfc_resolve_expr (lbound_e
);
2702 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2704 gfc_free_expr (lbound_e
);
2707 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2709 gfc_free_expr (ar
->start
[i
]);
2710 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2712 gfc_free_expr (ar
->end
[i
]);
2714 gfc_free_expr (ar
->stride
[i
]);
2715 ar
->stride
[i
] = NULL
;
2716 gfc_simplify_expr (ar
->start
[i
], 0);
2718 else if (was_fullref
)
2720 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2729 /* Helper function to check for a dimen vector as subscript. */
2732 has_dimen_vector_ref (gfc_expr
*e
)
2737 ar
= gfc_find_array_ref (e
);
2739 if (ar
->type
== AR_FULL
)
2742 for (i
=0; i
<ar
->dimen
; i
++)
2743 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2749 /* If handed an expression of the form
2753 check if A can be handled by matmul and return if there is an uneven number
2754 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2755 otherwise. The caller has to check for the correct rank. */
2758 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2765 if (e
->expr_type
== EXPR_VARIABLE
)
2767 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2770 else if (e
->expr_type
== EXPR_FUNCTION
)
2772 if (e
->value
.function
.isym
== NULL
)
2775 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2777 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2778 *transpose
= !*transpose
;
2784 e
= e
->value
.function
.actual
->expr
;
2791 /* Inline assignments of the form c = matmul(a,b).
2792 Handle only the cases currently where b and c are rank-two arrays.
2794 This basically translates the code to
2800 do k=0, size(a, 2)-1
2801 do i=0, size(a, 1)-1
2802 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2803 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2804 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2805 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2814 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2815 void *data ATTRIBUTE_UNUSED
)
2818 gfc_expr
*expr1
, *expr2
;
2819 gfc_expr
*matrix_a
, *matrix_b
;
2820 gfc_actual_arglist
*a
, *b
;
2821 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2823 gfc_expr
*u1
, *u2
, *u3
;
2825 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2827 gfc_expr
*var_1
, *var_2
, *var_3
;
2830 gfc_intrinsic_op op_times
, op_plus
;
2831 enum matrix_case m_case
;
2833 gfc_code
*if_limit
= NULL
;
2834 gfc_code
**next_code_point
;
2835 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2837 if (co
->op
!= EXEC_ASSIGN
)
2843 /* For now don't do anything in OpenMP workshare, it confuses
2844 its translation, which expects only the allowed statements in there.
2845 We should figure out how to parallelize this eventually. */
2846 if (in_omp_workshare
)
2851 if (expr2
->expr_type
!= EXPR_FUNCTION
2852 || expr2
->value
.function
.isym
== NULL
2853 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2857 inserted_block
= NULL
;
2858 changed_statement
= NULL
;
2860 a
= expr2
->value
.function
.actual
;
2861 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2862 if (transpose_a
|| matrix_a
== NULL
)
2866 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2867 if (matrix_b
== NULL
)
2870 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2871 || has_dimen_vector_ref (matrix_b
))
2874 /* We do not handle data dependencies yet. */
2875 if (gfc_check_dependency (expr1
, matrix_a
, true)
2876 || gfc_check_dependency (expr1
, matrix_b
, true))
2879 if (matrix_a
->rank
== 2)
2881 if (matrix_b
->rank
== 1)
2893 /* Vector * Transpose(B) not handled yet. */
2903 ns
= insert_block ();
2905 /* Assign the type of the zero expression for initializing the resulting
2906 array, and the expression (+ and * for real, integer and complex;
2907 .and. and .or for logical. */
2909 switch(expr1
->ts
.type
)
2912 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2913 op_times
= INTRINSIC_TIMES
;
2914 op_plus
= INTRINSIC_PLUS
;
2918 op_times
= INTRINSIC_AND
;
2919 op_plus
= INTRINSIC_OR
;
2920 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2924 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2926 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2927 op_times
= INTRINSIC_TIMES
;
2928 op_plus
= INTRINSIC_PLUS
;
2932 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2934 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2935 op_times
= INTRINSIC_TIMES
;
2936 op_plus
= INTRINSIC_PLUS
;
2944 current_code
= &ns
->code
;
2946 /* Freeze the references, keeping track of how many temporary variables were
2949 freeze_references (matrix_a
);
2950 freeze_references (matrix_b
);
2951 freeze_references (expr1
);
2954 next_code_point
= current_code
;
2957 next_code_point
= &ns
->code
;
2958 for (i
=0; i
<n_vars
; i
++)
2959 next_code_point
= &(*next_code_point
)->next
;
2962 /* Take care of the inline flag. If the limit check evaluates to a
2963 constant, dead code elimination will eliminate the unneeded branch. */
2965 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2967 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2969 /* Insert the original statement into the else branch. */
2970 if_limit
->block
->block
->next
= co
;
2973 /* ... and the new ones go into the original one. */
2974 *next_code_point
= if_limit
;
2975 next_code_point
= &if_limit
->block
->next
;
2978 assign_zero
= XCNEW (gfc_code
);
2979 assign_zero
->op
= EXEC_ASSIGN
;
2980 assign_zero
->loc
= co
->loc
;
2981 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2982 assign_zero
->expr2
= zero_e
;
2984 /* Handle the reallocation, if needed. */
2985 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2987 gfc_code
*lhs_alloc
;
2989 /* Only need to check a single dimension for the A2B2 case for
2990 bounds checking, the rest will be allocated. */
2992 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2997 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2998 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2999 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3000 "in MATMUL intrinsic: Is %ld, should be %ld");
3001 *next_code_point
= test
;
3002 next_code_point
= &test
->next
;
3006 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3008 *next_code_point
= lhs_alloc
;
3009 next_code_point
= &lhs_alloc
->next
;
3012 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3015 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3017 if (m_case
== A2B2
|| m_case
== A2B1
)
3019 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3020 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3021 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3022 "in MATMUL intrinsic: Is %ld, should be %ld");
3023 *next_code_point
= test
;
3024 next_code_point
= &test
->next
;
3026 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3027 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3030 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3031 "MATMUL intrinsic for dimension 1: "
3032 "is %ld, should be %ld");
3033 else if (m_case
== A2B1
)
3034 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3035 "MATMUL intrinsic: "
3036 "is %ld, should be %ld");
3039 *next_code_point
= test
;
3040 next_code_point
= &test
->next
;
3042 else if (m_case
== A1B2
)
3044 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3045 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3046 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3047 "in MATMUL intrinsic: Is %ld, should be %ld");
3048 *next_code_point
= test
;
3049 next_code_point
= &test
->next
;
3051 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3052 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3054 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3055 "MATMUL intrinsic: "
3056 "is %ld, should be %ld");
3058 *next_code_point
= test
;
3059 next_code_point
= &test
->next
;
3064 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3065 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3066 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3067 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3069 *next_code_point
= test
;
3070 next_code_point
= &test
->next
;
3073 if (m_case
== A2B2T
)
3075 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3076 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3077 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3078 "MATMUL intrinsic for dimension 1: "
3079 "is %ld, should be %ld");
3081 *next_code_point
= test
;
3082 next_code_point
= &test
->next
;
3084 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3085 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3086 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3087 "MATMUL intrinsic for dimension 2: "
3088 "is %ld, should be %ld");
3089 *next_code_point
= test
;
3090 next_code_point
= &test
->next
;
3092 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3093 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3095 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3096 "MATMUL intrnisic for dimension 2: "
3097 "is %ld, should be %ld");
3098 *next_code_point
= test
;
3099 next_code_point
= &test
->next
;
3104 *next_code_point
= assign_zero
;
3106 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3108 assign_matmul
= XCNEW (gfc_code
);
3109 assign_matmul
->op
= EXEC_ASSIGN
;
3110 assign_matmul
->loc
= co
->loc
;
3112 /* Get the bounds for the loops, create them and create the scalarized
3118 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3120 u1
= get_size_m1 (matrix_b
, 2);
3121 u2
= get_size_m1 (matrix_a
, 2);
3122 u3
= get_size_m1 (matrix_a
, 1);
3124 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3125 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3126 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3128 do_1
->block
->next
= do_2
;
3129 do_2
->block
->next
= do_3
;
3130 do_3
->block
->next
= assign_matmul
;
3132 var_1
= do_1
->ext
.iterator
->var
;
3133 var_2
= do_2
->ext
.iterator
->var
;
3134 var_3
= do_3
->ext
.iterator
->var
;
3138 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3142 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3146 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3151 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3153 u1
= get_size_m1 (matrix_b
, 1);
3154 u2
= get_size_m1 (matrix_a
, 2);
3155 u3
= get_size_m1 (matrix_a
, 1);
3157 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3158 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3159 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3161 do_1
->block
->next
= do_2
;
3162 do_2
->block
->next
= do_3
;
3163 do_3
->block
->next
= assign_matmul
;
3165 var_1
= do_1
->ext
.iterator
->var
;
3166 var_2
= do_2
->ext
.iterator
->var
;
3167 var_3
= do_3
->ext
.iterator
->var
;
3171 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3175 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3179 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3184 u1
= get_size_m1 (matrix_b
, 1);
3185 u2
= get_size_m1 (matrix_a
, 1);
3187 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3188 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3190 do_1
->block
->next
= do_2
;
3191 do_2
->block
->next
= assign_matmul
;
3193 var_1
= do_1
->ext
.iterator
->var
;
3194 var_2
= do_2
->ext
.iterator
->var
;
3197 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3201 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3204 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3209 u1
= get_size_m1 (matrix_b
, 2);
3210 u2
= get_size_m1 (matrix_a
, 1);
3212 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3213 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3215 do_1
->block
->next
= do_2
;
3216 do_2
->block
->next
= assign_matmul
;
3218 var_1
= do_1
->ext
.iterator
->var
;
3219 var_2
= do_2
->ext
.iterator
->var
;
3222 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3225 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3229 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3238 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3239 matrix_a
->where
, 1, ascalar
);
3242 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3243 matrix_b
->where
, 1, bscalar
);
3245 /* First loop comes after the zero assignment. */
3246 assign_zero
->next
= do_1
;
3248 /* Build the assignment expression in the loop. */
3249 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3251 mult
= get_operand (op_times
, ascalar
, bscalar
);
3252 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3254 /* If we don't want to keep the original statement around in
3255 the else branch, we can free it. */
3257 if (if_limit
== NULL
)
3258 gfc_free_statements(co
);
3262 gfc_free_expr (zero
);
3267 #define WALK_SUBEXPR(NODE) \
3270 result = gfc_expr_walker (&(NODE), exprfn, data); \
3275 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3277 /* Walk expression *E, calling EXPRFN on each expression in it. */
3280 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3284 int walk_subtrees
= 1;
3285 gfc_actual_arglist
*a
;
3289 int result
= exprfn (e
, &walk_subtrees
, data
);
3293 switch ((*e
)->expr_type
)
3296 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3297 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3300 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3301 WALK_SUBEXPR (a
->expr
);
3305 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3306 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3307 WALK_SUBEXPR (a
->expr
);
3310 case EXPR_STRUCTURE
:
3312 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3313 c
= gfc_constructor_next (c
))
3315 if (c
->iterator
== NULL
)
3316 WALK_SUBEXPR (c
->expr
);
3320 WALK_SUBEXPR (c
->expr
);
3322 WALK_SUBEXPR (c
->iterator
->var
);
3323 WALK_SUBEXPR (c
->iterator
->start
);
3324 WALK_SUBEXPR (c
->iterator
->end
);
3325 WALK_SUBEXPR (c
->iterator
->step
);
3329 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3332 /* Fall through to the variable case in order to walk the
3335 case EXPR_SUBSTRING
:
3337 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3346 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3348 for (i
=0; i
< ar
->dimen
; i
++)
3350 WALK_SUBEXPR (ar
->start
[i
]);
3351 WALK_SUBEXPR (ar
->end
[i
]);
3352 WALK_SUBEXPR (ar
->stride
[i
]);
3359 WALK_SUBEXPR (r
->u
.ss
.start
);
3360 WALK_SUBEXPR (r
->u
.ss
.end
);
3376 #define WALK_SUBCODE(NODE) \
3379 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3385 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3386 on each expression in it. If any of the hooks returns non-zero, that
3387 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3388 no subcodes or subexpressions are traversed. */
3391 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3394 for (; *c
; c
= &(*c
)->next
)
3396 int walk_subtrees
= 1;
3397 int result
= codefn (c
, &walk_subtrees
, data
);
3404 gfc_actual_arglist
*a
;
3406 gfc_association_list
*alist
;
3407 bool saved_in_omp_workshare
;
3408 bool saved_in_where
;
3410 /* There might be statement insertions before the current code,
3411 which must not affect the expression walker. */
3414 saved_in_omp_workshare
= in_omp_workshare
;
3415 saved_in_where
= in_where
;
3421 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3422 if (co
->ext
.block
.assoc
)
3424 bool saved_in_assoc_list
= in_assoc_list
;
3426 in_assoc_list
= true;
3427 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3428 WALK_SUBEXPR (alist
->target
);
3430 in_assoc_list
= saved_in_assoc_list
;
3437 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3438 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3439 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3440 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3448 case EXEC_ASSIGN_CALL
:
3449 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3450 WALK_SUBEXPR (a
->expr
);
3454 WALK_SUBEXPR (co
->expr1
);
3455 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3456 WALK_SUBEXPR (a
->expr
);
3460 WALK_SUBEXPR (co
->expr1
);
3461 for (b
= co
->block
; b
; b
= b
->block
)
3464 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3466 WALK_SUBEXPR (cp
->low
);
3467 WALK_SUBEXPR (cp
->high
);
3469 WALK_SUBCODE (b
->next
);
3474 case EXEC_DEALLOCATE
:
3477 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3478 WALK_SUBEXPR (a
->expr
);
3483 case EXEC_DO_CONCURRENT
:
3485 gfc_forall_iterator
*fa
;
3486 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3488 WALK_SUBEXPR (fa
->var
);
3489 WALK_SUBEXPR (fa
->start
);
3490 WALK_SUBEXPR (fa
->end
);
3491 WALK_SUBEXPR (fa
->stride
);
3493 if (co
->op
== EXEC_FORALL
)
3499 WALK_SUBEXPR (co
->ext
.open
->unit
);
3500 WALK_SUBEXPR (co
->ext
.open
->file
);
3501 WALK_SUBEXPR (co
->ext
.open
->status
);
3502 WALK_SUBEXPR (co
->ext
.open
->access
);
3503 WALK_SUBEXPR (co
->ext
.open
->form
);
3504 WALK_SUBEXPR (co
->ext
.open
->recl
);
3505 WALK_SUBEXPR (co
->ext
.open
->blank
);
3506 WALK_SUBEXPR (co
->ext
.open
->position
);
3507 WALK_SUBEXPR (co
->ext
.open
->action
);
3508 WALK_SUBEXPR (co
->ext
.open
->delim
);
3509 WALK_SUBEXPR (co
->ext
.open
->pad
);
3510 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3511 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3512 WALK_SUBEXPR (co
->ext
.open
->convert
);
3513 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3514 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3515 WALK_SUBEXPR (co
->ext
.open
->round
);
3516 WALK_SUBEXPR (co
->ext
.open
->sign
);
3517 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3518 WALK_SUBEXPR (co
->ext
.open
->id
);
3519 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3523 WALK_SUBEXPR (co
->ext
.close
->unit
);
3524 WALK_SUBEXPR (co
->ext
.close
->status
);
3525 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3526 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3529 case EXEC_BACKSPACE
:
3533 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3534 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3535 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3539 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3540 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3541 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3542 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3543 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3544 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3545 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3546 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3547 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3548 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3549 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3550 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3551 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3552 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3553 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3554 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3555 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3556 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3557 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3558 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3559 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3560 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3561 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3562 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3563 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3564 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3565 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3566 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3567 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3568 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3569 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3570 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3571 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3572 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3573 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3574 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3578 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3579 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3580 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3581 WALK_SUBEXPR (co
->ext
.wait
->id
);
3586 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3587 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3588 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3589 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3590 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3591 WALK_SUBEXPR (co
->ext
.dt
->size
);
3592 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3593 WALK_SUBEXPR (co
->ext
.dt
->id
);
3594 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3595 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3596 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3597 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3598 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3599 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3600 WALK_SUBEXPR (co
->ext
.dt
->round
);
3601 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3602 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3605 case EXEC_OMP_PARALLEL
:
3606 case EXEC_OMP_PARALLEL_DO
:
3607 case EXEC_OMP_PARALLEL_DO_SIMD
:
3608 case EXEC_OMP_PARALLEL_SECTIONS
:
3610 in_omp_workshare
= false;
3612 /* This goto serves as a shortcut to avoid code
3613 duplication or a larger if or switch statement. */
3614 goto check_omp_clauses
;
3616 case EXEC_OMP_WORKSHARE
:
3617 case EXEC_OMP_PARALLEL_WORKSHARE
:
3619 in_omp_workshare
= true;
3623 case EXEC_OMP_DISTRIBUTE
:
3624 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3625 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3626 case EXEC_OMP_DISTRIBUTE_SIMD
:
3628 case EXEC_OMP_DO_SIMD
:
3629 case EXEC_OMP_SECTIONS
:
3630 case EXEC_OMP_SINGLE
:
3631 case EXEC_OMP_END_SINGLE
:
3633 case EXEC_OMP_TARGET
:
3634 case EXEC_OMP_TARGET_DATA
:
3635 case EXEC_OMP_TARGET_TEAMS
:
3636 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3637 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3638 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3639 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3640 case EXEC_OMP_TARGET_UPDATE
:
3642 case EXEC_OMP_TEAMS
:
3643 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3644 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3645 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3646 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3648 /* Come to this label only from the
3649 EXEC_OMP_PARALLEL_* cases above. */
3653 if (co
->ext
.omp_clauses
)
3655 gfc_omp_namelist
*n
;
3656 static int list_types
[]
3657 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3658 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3660 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3661 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3662 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3663 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3664 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3665 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3666 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3667 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3668 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3669 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3671 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3673 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3675 WALK_SUBEXPR (n
->expr
);
3682 WALK_SUBEXPR (co
->expr1
);
3683 WALK_SUBEXPR (co
->expr2
);
3684 WALK_SUBEXPR (co
->expr3
);
3685 WALK_SUBEXPR (co
->expr4
);
3686 for (b
= co
->block
; b
; b
= b
->block
)
3688 WALK_SUBEXPR (b
->expr1
);
3689 WALK_SUBEXPR (b
->expr2
);
3690 WALK_SUBCODE (b
->next
);
3693 if (co
->op
== EXEC_FORALL
)
3696 if (co
->op
== EXEC_DO
)
3699 in_omp_workshare
= saved_in_omp_workshare
;
3700 in_where
= saved_in_where
;