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
)
1141 /* Check for a // b // trim(c). Looping is probably not
1142 necessary because the parser usually generates
1143 (// (// a b ) trim(c) ) , but better safe than sorry. */
1145 while (rhs
->expr_type
== EXPR_OP
1146 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1147 rhs
= rhs
->value
.op
.op2
;
1149 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1150 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1152 strip_function_call (rhs
);
1153 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1161 /* Optimizations for an assignment. */
1164 optimize_assignment (gfc_code
* c
)
1166 gfc_expr
*lhs
, *rhs
;
1171 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1173 /* Optimize a = trim(b) to a = b. */
1176 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1177 if (is_empty_string (rhs
))
1178 rhs
->value
.character
.length
= 0;
1181 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1182 optimize_binop_array_assignment (c
, &rhs
, false);
1186 /* Remove an unneeded function call, modifying the expression.
1187 This replaces the function call with the value of its
1188 first argument. The rest of the argument list is freed. */
1191 strip_function_call (gfc_expr
*e
)
1194 gfc_actual_arglist
*a
;
1196 a
= e
->value
.function
.actual
;
1198 /* We should have at least one argument. */
1199 gcc_assert (a
->expr
!= NULL
);
1203 /* Free the remaining arglist, if any. */
1205 gfc_free_actual_arglist (a
->next
);
1207 /* Graft the argument expression onto the original function. */
1213 /* Optimization of lexical comparison functions. */
1216 optimize_lexical_comparison (gfc_expr
*e
)
1218 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1221 switch (e
->value
.function
.isym
->id
)
1224 return optimize_comparison (e
, INTRINSIC_LE
);
1227 return optimize_comparison (e
, INTRINSIC_GE
);
1230 return optimize_comparison (e
, INTRINSIC_GT
);
1233 return optimize_comparison (e
, INTRINSIC_LT
);
1241 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1242 do CHARACTER because of possible pessimization involving character
1246 combine_array_constructor (gfc_expr
*e
)
1249 gfc_expr
*op1
, *op2
;
1252 gfc_constructor
*c
, *new_c
;
1253 gfc_constructor_base oldbase
, newbase
;
1256 /* Array constructors have rank one. */
1260 /* Don't try to combine association lists, this makes no sense
1261 and leads to an ICE. */
1265 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1266 if (forall_level
> 0)
1269 /* Inside an iterator, things can get hairy; we are likely to create
1270 an invalid temporary variable. */
1271 if (iterator_level
> 0)
1274 op1
= e
->value
.op
.op1
;
1275 op2
= e
->value
.op
.op2
;
1277 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1278 scalar_first
= false;
1279 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1281 scalar_first
= true;
1282 op1
= e
->value
.op
.op2
;
1283 op2
= e
->value
.op
.op1
;
1288 if (op2
->ts
.type
== BT_CHARACTER
)
1291 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1293 oldbase
= op1
->value
.constructor
;
1295 e
->expr_type
= EXPR_ARRAY
;
1297 for (c
= gfc_constructor_first (oldbase
); c
;
1298 c
= gfc_constructor_next (c
))
1300 new_expr
= gfc_get_expr ();
1301 new_expr
->ts
= e
->ts
;
1302 new_expr
->expr_type
= EXPR_OP
;
1303 new_expr
->rank
= c
->expr
->rank
;
1304 new_expr
->where
= c
->where
;
1305 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1309 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1310 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1314 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1315 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1318 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1319 new_c
->iterator
= c
->iterator
;
1323 gfc_free_expr (op1
);
1324 gfc_free_expr (op2
);
1325 gfc_free_expr (scalar
);
1327 e
->value
.constructor
= newbase
;
1331 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1332 2**k into ishift(1,k) */
1335 optimize_power (gfc_expr
*e
)
1337 gfc_expr
*op1
, *op2
;
1338 gfc_expr
*iand
, *ishft
;
1340 if (e
->ts
.type
!= BT_INTEGER
)
1343 op1
= e
->value
.op
.op1
;
1345 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1348 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1350 gfc_free_expr (op1
);
1352 op2
= e
->value
.op
.op2
;
1357 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1358 "_internal_iand", e
->where
, 2, op2
,
1359 gfc_get_int_expr (e
->ts
.kind
,
1362 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1363 "_internal_ishft", e
->where
, 2, iand
,
1364 gfc_get_int_expr (e
->ts
.kind
,
1367 e
->value
.op
.op
= INTRINSIC_MINUS
;
1368 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1369 e
->value
.op
.op2
= ishft
;
1372 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1374 gfc_free_expr (op1
);
1376 op2
= e
->value
.op
.op2
;
1380 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1381 "_internal_ishft", e
->where
, 2,
1382 gfc_get_int_expr (e
->ts
.kind
,
1389 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1391 op2
= e
->value
.op
.op2
;
1395 gfc_free_expr (op1
);
1396 gfc_free_expr (op2
);
1398 e
->expr_type
= EXPR_CONSTANT
;
1399 e
->value
.op
.op1
= NULL
;
1400 e
->value
.op
.op2
= NULL
;
1401 mpz_init_set_si (e
->value
.integer
, 1);
1402 /* Typespec and location are still OK. */
1409 /* Recursive optimization of operators. */
1412 optimize_op (gfc_expr
*e
)
1416 gfc_intrinsic_op op
= e
->value
.op
.op
;
1420 /* Only use new-style comparisons. */
1423 case INTRINSIC_EQ_OS
:
1427 case INTRINSIC_GE_OS
:
1431 case INTRINSIC_LE_OS
:
1435 case INTRINSIC_NE_OS
:
1439 case INTRINSIC_GT_OS
:
1443 case INTRINSIC_LT_OS
:
1459 changed
= optimize_comparison (e
, op
);
1462 /* Look at array constructors. */
1463 case INTRINSIC_PLUS
:
1464 case INTRINSIC_MINUS
:
1465 case INTRINSIC_TIMES
:
1466 case INTRINSIC_DIVIDE
:
1467 return combine_array_constructor (e
) || changed
;
1469 case INTRINSIC_POWER
:
1470 return optimize_power (e
);
1481 /* Return true if a constant string contains only blanks. */
1484 is_empty_string (gfc_expr
*e
)
1488 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1491 for (i
=0; i
< e
->value
.character
.length
; i
++)
1493 if (e
->value
.character
.string
[i
] != ' ')
1501 /* Insert a call to the intrinsic len_trim. Use a different name for
1502 the symbol tree so we don't run into trouble when the user has
1503 renamed len_trim for some reason. */
1506 get_len_trim_call (gfc_expr
*str
, int kind
)
1509 gfc_actual_arglist
*actual_arglist
, *next
;
1511 fcn
= gfc_get_expr ();
1512 fcn
->expr_type
= EXPR_FUNCTION
;
1513 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1514 actual_arglist
= gfc_get_actual_arglist ();
1515 actual_arglist
->expr
= str
;
1516 next
= gfc_get_actual_arglist ();
1517 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1518 actual_arglist
->next
= next
;
1520 fcn
->value
.function
.actual
= actual_arglist
;
1521 fcn
->where
= str
->where
;
1522 fcn
->ts
.type
= BT_INTEGER
;
1523 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1525 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1526 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1527 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1528 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1529 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1530 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1531 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1532 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1537 /* Optimize expressions for equality. */
1540 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1542 gfc_expr
*op1
, *op2
;
1546 gfc_actual_arglist
*firstarg
, *secondarg
;
1548 if (e
->expr_type
== EXPR_OP
)
1552 op1
= e
->value
.op
.op1
;
1553 op2
= e
->value
.op
.op2
;
1555 else if (e
->expr_type
== EXPR_FUNCTION
)
1557 /* One of the lexical comparison functions. */
1558 firstarg
= e
->value
.function
.actual
;
1559 secondarg
= firstarg
->next
;
1560 op1
= firstarg
->expr
;
1561 op2
= secondarg
->expr
;
1566 /* Strip off unneeded TRIM calls from string comparisons. */
1568 change
= remove_trim (op1
);
1570 if (remove_trim (op2
))
1573 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1574 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1575 handles them well). However, there are also cases that need a non-scalar
1576 argument. For example the any intrinsic. See PR 45380. */
1580 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1582 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1583 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1585 bool empty_op1
, empty_op2
;
1586 empty_op1
= is_empty_string (op1
);
1587 empty_op2
= is_empty_string (op2
);
1589 if (empty_op1
|| empty_op2
)
1595 /* This can only happen when an error for comparing
1596 characters of different kinds has already been issued. */
1597 if (empty_op1
&& empty_op2
)
1600 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1601 str
= empty_op1
? op2
: op1
;
1603 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1607 gfc_free_expr (op1
);
1609 gfc_free_expr (op2
);
1613 e
->value
.op
.op1
= fcn
;
1614 e
->value
.op
.op2
= zero
;
1619 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1621 if (flag_finite_math_only
1622 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1623 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1625 eq
= gfc_dep_compare_expr (op1
, op2
);
1628 /* Replace A // B < A // C with B < C, and A // B < C // B
1630 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1631 && op1
->expr_type
== EXPR_OP
1632 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1633 && op2
->expr_type
== EXPR_OP
1634 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1636 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1637 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1638 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1639 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1641 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1643 /* Watch out for 'A ' // x vs. 'A' // x. */
1645 if (op1_left
->expr_type
== EXPR_CONSTANT
1646 && op2_left
->expr_type
== EXPR_CONSTANT
1647 && op1_left
->value
.character
.length
1648 != op2_left
->value
.character
.length
)
1656 firstarg
->expr
= op1_right
;
1657 secondarg
->expr
= op2_right
;
1661 e
->value
.op
.op1
= op1_right
;
1662 e
->value
.op
.op2
= op2_right
;
1664 optimize_comparison (e
, op
);
1668 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1674 firstarg
->expr
= op1_left
;
1675 secondarg
->expr
= op2_left
;
1679 e
->value
.op
.op1
= op1_left
;
1680 e
->value
.op
.op2
= op2_left
;
1683 optimize_comparison (e
, op
);
1690 /* eq can only be -1, 0 or 1 at this point. */
1718 gfc_internal_error ("illegal OP in optimize_comparison");
1722 /* Replace the expression by a constant expression. The typespec
1723 and where remains the way it is. */
1726 e
->expr_type
= EXPR_CONSTANT
;
1727 e
->value
.logical
= result
;
1735 /* Optimize a trim function by replacing it with an equivalent substring
1736 involving a call to len_trim. This only works for expressions where
1737 variables are trimmed. Return true if anything was modified. */
1740 optimize_trim (gfc_expr
*e
)
1745 gfc_ref
**rr
= NULL
;
1747 /* Don't do this optimization within an argument list, because
1748 otherwise aliasing issues may occur. */
1750 if (count_arglist
!= 1)
1753 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1754 || e
->value
.function
.isym
== NULL
1755 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1758 a
= e
->value
.function
.actual
->expr
;
1760 if (a
->expr_type
!= EXPR_VARIABLE
)
1763 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1765 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1768 /* Follow all references to find the correct place to put the newly
1769 created reference. FIXME: Also handle substring references and
1770 array references. Array references cause strange regressions at
1775 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1777 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1782 strip_function_call (e
);
1787 /* Create the reference. */
1789 ref
= gfc_get_ref ();
1790 ref
->type
= REF_SUBSTRING
;
1792 /* Set the start of the reference. */
1794 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1796 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1798 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1800 /* Set the end of the reference to the call to len_trim. */
1802 ref
->u
.ss
.end
= fcn
;
1803 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1808 /* Optimize minloc(b), where b is rank 1 array, into
1809 (/ minloc(b, dim=1) /), and similarly for maxloc,
1810 as the latter forms are expanded inline. */
1813 optimize_minmaxloc (gfc_expr
**e
)
1816 gfc_actual_arglist
*a
;
1820 || fn
->value
.function
.actual
== NULL
1821 || fn
->value
.function
.actual
->expr
== NULL
1822 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1825 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1826 (*e
)->shape
= fn
->shape
;
1829 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1831 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1832 strcpy (name
, fn
->value
.function
.name
);
1833 p
= strstr (name
, "loc0");
1835 fn
->value
.function
.name
= gfc_get_string (name
);
1836 if (fn
->value
.function
.actual
->next
)
1838 a
= fn
->value
.function
.actual
->next
;
1839 gcc_assert (a
->expr
== NULL
);
1843 a
= gfc_get_actual_arglist ();
1844 fn
->value
.function
.actual
->next
= a
;
1846 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1848 mpz_set_ui (a
->expr
->value
.integer
, 1);
1851 /* Callback function for code checking that we do not pass a DO variable to an
1852 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1855 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1856 void *data ATTRIBUTE_UNUSED
)
1860 gfc_formal_arglist
*f
;
1861 gfc_actual_arglist
*a
;
1866 /* If the doloop_list grew, we have to truncate it here. */
1868 if ((unsigned) doloop_level
< doloop_list
.length())
1869 doloop_list
.truncate (doloop_level
);
1875 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1876 doloop_list
.safe_push (co
);
1878 doloop_list
.safe_push ((gfc_code
*) NULL
);
1883 if (co
->resolved_sym
== NULL
)
1886 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1888 /* Withot a formal arglist, there is only unknown INTENT,
1889 which we don't check for. */
1897 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1904 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1906 if (a
->expr
&& a
->expr
->symtree
1907 && a
->expr
->symtree
->n
.sym
== do_sym
)
1909 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1910 gfc_error_now ("Variable %qs at %L set to undefined "
1911 "value inside loop beginning at %L as "
1912 "INTENT(OUT) argument to subroutine %qs",
1913 do_sym
->name
, &a
->expr
->where
,
1914 &doloop_list
[i
]->loc
,
1915 co
->symtree
->n
.sym
->name
);
1916 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1917 gfc_error_now ("Variable %qs at %L not definable inside "
1918 "loop beginning at %L as INTENT(INOUT) "
1919 "argument to subroutine %qs",
1920 do_sym
->name
, &a
->expr
->where
,
1921 &doloop_list
[i
]->loc
,
1922 co
->symtree
->n
.sym
->name
);
1936 /* Callback function for functions checking that we do not pass a DO variable
1937 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1940 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1941 void *data ATTRIBUTE_UNUSED
)
1943 gfc_formal_arglist
*f
;
1944 gfc_actual_arglist
*a
;
1950 if (expr
->expr_type
!= EXPR_FUNCTION
)
1953 /* Intrinsic functions don't modify their arguments. */
1955 if (expr
->value
.function
.isym
)
1958 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1960 /* Without a formal arglist, there is only unknown INTENT,
1961 which we don't check for. */
1965 a
= expr
->value
.function
.actual
;
1969 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1976 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1978 if (a
->expr
&& a
->expr
->symtree
1979 && a
->expr
->symtree
->n
.sym
== do_sym
)
1981 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1982 gfc_error_now ("Variable %qs at %L set to undefined value "
1983 "inside loop beginning at %L as INTENT(OUT) "
1984 "argument to function %qs", do_sym
->name
,
1985 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1986 expr
->symtree
->n
.sym
->name
);
1987 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1988 gfc_error_now ("Variable %qs at %L not definable inside loop"
1989 " beginning at %L as INTENT(INOUT) argument to"
1990 " function %qs", do_sym
->name
,
1991 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1992 expr
->symtree
->n
.sym
->name
);
2003 doloop_warn (gfc_namespace
*ns
)
2005 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2008 /* This selction deals with inlining calls to MATMUL. */
2010 /* Auxiliary function to build and simplify an array inquiry function.
2011 dim is zero-based. */
2014 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2017 gfc_expr
*dim_arg
, *kind
;
2023 case GFC_ISYM_LBOUND
:
2024 name
= "_gfortran_lbound";
2027 case GFC_ISYM_UBOUND
:
2028 name
= "_gfortran_ubound";
2032 name
= "_gfortran_size";
2039 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2040 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2041 gfc_index_integer_kind
);
2043 ec
= gfc_copy_expr (e
);
2044 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2046 gfc_simplify_expr (fcn
, 0);
2050 /* Builds a logical expression. */
2053 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2058 ts
.type
= BT_LOGICAL
;
2059 ts
.kind
= gfc_default_logical_kind
;
2060 res
= gfc_get_expr ();
2061 res
->where
= e1
->where
;
2062 res
->expr_type
= EXPR_OP
;
2063 res
->value
.op
.op
= op
;
2064 res
->value
.op
.op1
= e1
;
2065 res
->value
.op
.op2
= e2
;
2072 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2073 compatible typespecs. */
2076 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2080 res
= gfc_get_expr ();
2082 res
->where
= e1
->where
;
2083 res
->expr_type
= EXPR_OP
;
2084 res
->value
.op
.op
= op
;
2085 res
->value
.op
.op1
= e1
;
2086 res
->value
.op
.op2
= e2
;
2087 gfc_simplify_expr (res
, 0);
2091 /* Generate the IF statement for a runtime check if we want to do inlining or
2092 not - putting in the code for both branches and putting it into the syntax
2093 tree is the caller's responsibility. For fixed array sizes, this should be
2094 removed by DCE. Only called for rank-two matrices A and B. */
2097 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2099 gfc_expr
*inline_limit
;
2100 gfc_code
*if_1
, *if_2
, *else_2
;
2101 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2105 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2107 /* Calculation is done in real to avoid integer overflow. */
2109 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2111 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2113 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2116 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2117 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2118 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2122 ts
.kind
= gfc_default_real_kind
;
2123 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2124 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2125 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2127 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2128 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2130 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2131 gfc_simplify_expr (cond
, 0);
2133 else_2
= XCNEW (gfc_code
);
2134 else_2
->op
= EXEC_IF
;
2135 else_2
->loc
= a
->where
;
2137 if_2
= XCNEW (gfc_code
);
2140 if_2
->loc
= a
->where
;
2141 if_2
->block
= else_2
;
2143 if_1
= XCNEW (gfc_code
);
2146 if_1
->loc
= a
->where
;
2152 /* Insert code to issue a runtime error if the expressions are not equal. */
2155 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2158 gfc_code
*if_1
, *if_2
;
2160 gfc_actual_arglist
*a1
, *a2
, *a3
;
2162 gcc_assert (e1
->where
.lb
);
2163 /* Build the call to runtime_error. */
2164 c
= XCNEW (gfc_code
);
2168 /* Get a null-terminated message string. */
2170 a1
= gfc_get_actual_arglist ();
2171 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2172 msg
, strlen(msg
)+1);
2175 /* Pass the value of the first expression. */
2176 a2
= gfc_get_actual_arglist ();
2177 a2
->expr
= gfc_copy_expr (e1
);
2180 /* Pass the value of the second expression. */
2181 a3
= gfc_get_actual_arglist ();
2182 a3
->expr
= gfc_copy_expr (e2
);
2185 gfc_check_fe_runtime_error (c
->ext
.actual
);
2186 gfc_resolve_fe_runtime_error (c
);
2188 if_2
= XCNEW (gfc_code
);
2190 if_2
->loc
= e1
->where
;
2193 if_1
= XCNEW (gfc_code
);
2196 if_1
->loc
= e1
->where
;
2198 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2199 gfc_simplify_expr (cond
, 0);
2205 /* Handle matrix reallocation. Caller is responsible to insert into
2208 For the two-dimensional case, build
2210 if (allocated(c)) then
2211 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2213 allocate (c(size(a,1), size(b,2)))
2216 allocate (c(size(a,1),size(b,2)))
2219 and for the other cases correspondingly.
2223 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2224 enum matrix_case m_case
)
2227 gfc_expr
*allocated
, *alloc_expr
;
2228 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2229 gfc_code
*else_alloc
;
2230 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2232 gfc_expr
*cond
, *ne1
, *ne2
;
2234 if (warn_realloc_lhs
)
2235 gfc_warning (OPT_Wrealloc_lhs
,
2236 "Code for reallocating the allocatable array at %L will "
2237 "be added", &c
->where
);
2239 alloc_expr
= gfc_copy_expr (c
);
2241 ar
= gfc_find_array_ref (alloc_expr
);
2242 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2244 /* c comes in as a full ref. Change it into a copy and make it into an
2245 element ref so it has the right form for for ALLOCATE. In the same
2246 switch statement, also generate the size comparison for the secod IF
2249 ar
->type
= AR_ELEMENT
;
2254 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2255 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2256 ne1
= build_logical_expr (INTRINSIC_NE
,
2257 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2258 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2259 ne2
= build_logical_expr (INTRINSIC_NE
,
2260 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2261 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2262 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2266 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2267 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2269 ne1
= build_logical_expr (INTRINSIC_NE
,
2270 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2271 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2272 ne2
= build_logical_expr (INTRINSIC_NE
,
2273 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2274 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2275 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2279 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2280 cond
= build_logical_expr (INTRINSIC_NE
,
2281 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2282 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2286 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2287 cond
= build_logical_expr (INTRINSIC_NE
,
2288 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2289 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2297 gfc_simplify_expr (cond
, 0);
2299 /* We need two identical allocate statements in two
2300 branches of the IF statement. */
2302 allocate1
= XCNEW (gfc_code
);
2303 allocate1
->op
= EXEC_ALLOCATE
;
2304 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2305 allocate1
->loc
= c
->where
;
2306 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2308 allocate_else
= XCNEW (gfc_code
);
2309 allocate_else
->op
= EXEC_ALLOCATE
;
2310 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2311 allocate_else
->loc
= c
->where
;
2312 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2314 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2315 "_gfortran_allocated", c
->where
,
2316 1, gfc_copy_expr (c
));
2318 deallocate
= XCNEW (gfc_code
);
2319 deallocate
->op
= EXEC_DEALLOCATE
;
2320 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2321 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2322 deallocate
->next
= allocate1
;
2323 deallocate
->loc
= c
->where
;
2325 if_size_2
= XCNEW (gfc_code
);
2326 if_size_2
->op
= EXEC_IF
;
2327 if_size_2
->expr1
= cond
;
2328 if_size_2
->loc
= c
->where
;
2329 if_size_2
->next
= deallocate
;
2331 if_size_1
= XCNEW (gfc_code
);
2332 if_size_1
->op
= EXEC_IF
;
2333 if_size_1
->block
= if_size_2
;
2334 if_size_1
->loc
= c
->where
;
2336 else_alloc
= XCNEW (gfc_code
);
2337 else_alloc
->op
= EXEC_IF
;
2338 else_alloc
->loc
= c
->where
;
2339 else_alloc
->next
= allocate_else
;
2341 if_alloc_2
= XCNEW (gfc_code
);
2342 if_alloc_2
->op
= EXEC_IF
;
2343 if_alloc_2
->expr1
= allocated
;
2344 if_alloc_2
->loc
= c
->where
;
2345 if_alloc_2
->next
= if_size_1
;
2346 if_alloc_2
->block
= else_alloc
;
2348 if_alloc_1
= XCNEW (gfc_code
);
2349 if_alloc_1
->op
= EXEC_IF
;
2350 if_alloc_1
->block
= if_alloc_2
;
2351 if_alloc_1
->loc
= c
->where
;
2356 /* Callback function for has_function_or_op. */
2359 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2360 void *data ATTRIBUTE_UNUSED
)
2365 return (*e
)->expr_type
== EXPR_FUNCTION
2366 || (*e
)->expr_type
== EXPR_OP
;
2369 /* Returns true if the expression contains a function. */
2372 has_function_or_op (gfc_expr
**e
)
2377 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2380 /* Freeze (assign to a temporary variable) a single expression. */
2383 freeze_expr (gfc_expr
**ep
)
2386 if (has_function_or_op (ep
))
2388 ne
= create_var (*ep
, "freeze");
2393 /* Go through an expression's references and assign them to temporary
2394 variables if they contain functions. This is usually done prior to
2395 front-end scalarization to avoid multiple invocations of functions. */
2398 freeze_references (gfc_expr
*e
)
2404 for (r
=e
->ref
; r
; r
=r
->next
)
2406 if (r
->type
== REF_SUBSTRING
)
2408 if (r
->u
.ss
.start
!= NULL
)
2409 freeze_expr (&r
->u
.ss
.start
);
2411 if (r
->u
.ss
.end
!= NULL
)
2412 freeze_expr (&r
->u
.ss
.end
);
2414 else if (r
->type
== REF_ARRAY
)
2423 for (i
=0; i
<ar
->dimen
; i
++)
2425 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2427 freeze_expr (&ar
->start
[i
]);
2428 freeze_expr (&ar
->end
[i
]);
2429 freeze_expr (&ar
->stride
[i
]);
2431 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2433 freeze_expr (&ar
->start
[i
]);
2439 for (i
=0; i
<ar
->dimen
; i
++)
2440 freeze_expr (&ar
->start
[i
]);
2450 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2453 convert_to_index_kind (gfc_expr
*e
)
2457 gcc_assert (e
!= NULL
);
2459 res
= gfc_copy_expr (e
);
2461 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2463 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2467 ts
.type
= BT_INTEGER
;
2468 ts
.kind
= gfc_index_integer_kind
;
2470 gfc_convert_type_warn (e
, &ts
, 2, 0);
2476 /* Function to create a DO loop including creation of the
2477 iteration variable. gfc_expr are copied.*/
2480 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2481 gfc_namespace
*ns
, char *vname
)
2484 char name
[GFC_MAX_SYMBOL_LEN
+1];
2485 gfc_symtree
*symtree
;
2490 /* Create an expression for the iteration variable. */
2492 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2494 sprintf (name
, "__var_%d_do", var_num
++);
2497 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2500 /* Create the loop variable. */
2502 symbol
= symtree
->n
.sym
;
2503 symbol
->ts
.type
= BT_INTEGER
;
2504 symbol
->ts
.kind
= gfc_index_integer_kind
;
2505 symbol
->attr
.flavor
= FL_VARIABLE
;
2506 symbol
->attr
.referenced
= 1;
2507 symbol
->attr
.dimension
= 0;
2508 symbol
->attr
.fe_temp
= 1;
2509 gfc_commit_symbol (symbol
);
2511 i
= gfc_get_expr ();
2512 i
->expr_type
= EXPR_VARIABLE
;
2516 i
->symtree
= symtree
;
2518 /* ... and the nested DO statements. */
2519 n
= XCNEW (gfc_code
);
2522 n
->ext
.iterator
= gfc_get_iterator ();
2523 n
->ext
.iterator
->var
= i
;
2524 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2525 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2527 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2529 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2532 n2
= XCNEW (gfc_code
);
2540 /* Get the upper bound of the DO loops for matmul along a dimension. This
2544 get_size_m1 (gfc_expr
*e
, int dimen
)
2549 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2551 res
= gfc_get_constant_expr (BT_INTEGER
,
2552 gfc_index_integer_kind
, &e
->where
);
2553 mpz_sub_ui (res
->value
.integer
, size
, 1);
2558 res
= get_operand (INTRINSIC_MINUS
,
2559 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2560 gfc_get_int_expr (gfc_index_integer_kind
,
2562 gfc_simplify_expr (res
, 0);
2568 /* Function to return a scalarized expression. It is assumed that indices are
2569 zero based to make generation of DO loops easier. A zero as index will
2570 access the first element along a dimension. Single element references will
2571 be skipped. A NULL as an expression will be replaced by a full reference.
2572 This assumes that the index loops have gfc_index_integer_kind, and that all
2573 references have been frozen. */
2576 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2585 e
= gfc_copy_expr(e_in
);
2589 ar
= gfc_find_array_ref (e
);
2591 /* We scalarize count_index variables, reducing the rank by count_index. */
2593 e
->rank
= rank
- count_index
;
2595 was_fullref
= ar
->type
== AR_FULL
;
2598 ar
->type
= AR_ELEMENT
;
2600 ar
->type
= AR_SECTION
;
2602 /* Loop over the indices. For each index, create the expression
2603 index * stride + lbound(e, dim). */
2606 for (i
=0; i
< ar
->dimen
; i
++)
2608 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2610 if (index
[i_index
] != NULL
)
2612 gfc_expr
*lbound
, *nindex
;
2615 loopvar
= gfc_copy_expr (index
[i_index
]);
2621 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2622 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2626 ts
.type
= BT_INTEGER
;
2627 ts
.kind
= gfc_index_integer_kind
;
2628 gfc_convert_type (tmp
, &ts
, 2);
2630 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2635 /* Calculate the lower bound of the expression. */
2638 lbound
= gfc_copy_expr (ar
->start
[i
]);
2639 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2643 ts
.type
= BT_INTEGER
;
2644 ts
.kind
= gfc_index_integer_kind
;
2645 gfc_convert_type (lbound
, &ts
, 2);
2654 lbound_e
= gfc_copy_expr (e_in
);
2656 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2657 if (ref
->type
== REF_ARRAY
2658 && (ref
->u
.ar
.type
== AR_FULL
2659 || ref
->u
.ar
.type
== AR_SECTION
))
2664 gfc_free_ref_list (ref
->next
);
2670 /* Look at full individual sections, like a(:). The first index
2671 is the lbound of a full ref. */
2677 for (j
= 0; j
< ar
->dimen
; j
++)
2679 gfc_free_expr (ar
->start
[j
]);
2680 ar
->start
[j
] = NULL
;
2681 gfc_free_expr (ar
->end
[j
]);
2683 gfc_free_expr (ar
->stride
[j
]);
2684 ar
->stride
[j
] = NULL
;
2687 /* We have to get rid of the shape, if there is one. Do
2688 so by freeing it and calling gfc_resolve to rebuild
2689 it, if necessary. */
2691 if (lbound_e
->shape
)
2692 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2694 lbound_e
->rank
= ar
->dimen
;
2695 gfc_resolve_expr (lbound_e
);
2697 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2699 gfc_free_expr (lbound_e
);
2702 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2704 gfc_free_expr (ar
->start
[i
]);
2705 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2707 gfc_free_expr (ar
->end
[i
]);
2709 gfc_free_expr (ar
->stride
[i
]);
2710 ar
->stride
[i
] = NULL
;
2711 gfc_simplify_expr (ar
->start
[i
], 0);
2713 else if (was_fullref
)
2715 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2724 /* Helper function to check for a dimen vector as subscript. */
2727 has_dimen_vector_ref (gfc_expr
*e
)
2732 ar
= gfc_find_array_ref (e
);
2734 if (ar
->type
== AR_FULL
)
2737 for (i
=0; i
<ar
->dimen
; i
++)
2738 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2744 /* If handed an expression of the form
2748 check if A can be handled by matmul and return if there is an uneven number
2749 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2750 otherwise. The caller has to check for the correct rank. */
2753 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2760 if (e
->expr_type
== EXPR_VARIABLE
)
2762 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2765 else if (e
->expr_type
== EXPR_FUNCTION
)
2767 if (e
->value
.function
.isym
== NULL
)
2770 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2772 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2773 *transpose
= !*transpose
;
2779 e
= e
->value
.function
.actual
->expr
;
2786 /* Inline assignments of the form c = matmul(a,b).
2787 Handle only the cases currently where b and c are rank-two arrays.
2789 This basically translates the code to
2795 do k=0, size(a, 2)-1
2796 do i=0, size(a, 1)-1
2797 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2798 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2799 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2800 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2809 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2810 void *data ATTRIBUTE_UNUSED
)
2813 gfc_expr
*expr1
, *expr2
;
2814 gfc_expr
*matrix_a
, *matrix_b
;
2815 gfc_actual_arglist
*a
, *b
;
2816 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2818 gfc_expr
*u1
, *u2
, *u3
;
2820 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2822 gfc_expr
*var_1
, *var_2
, *var_3
;
2825 gfc_intrinsic_op op_times
, op_plus
;
2826 enum matrix_case m_case
;
2828 gfc_code
*if_limit
= NULL
;
2829 gfc_code
**next_code_point
;
2830 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2832 if (co
->op
!= EXEC_ASSIGN
)
2838 /* For now don't do anything in OpenMP workshare, it confuses
2839 its translation, which expects only the allowed statements in there.
2840 We should figure out how to parallelize this eventually. */
2841 if (in_omp_workshare
)
2846 if (expr2
->expr_type
!= EXPR_FUNCTION
2847 || expr2
->value
.function
.isym
== NULL
2848 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2852 inserted_block
= NULL
;
2853 changed_statement
= NULL
;
2855 a
= expr2
->value
.function
.actual
;
2856 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2857 if (transpose_a
|| matrix_a
== NULL
)
2861 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2862 if (matrix_b
== NULL
)
2865 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2866 || has_dimen_vector_ref (matrix_b
))
2869 /* We do not handle data dependencies yet. */
2870 if (gfc_check_dependency (expr1
, matrix_a
, true)
2871 || gfc_check_dependency (expr1
, matrix_b
, true))
2874 if (matrix_a
->rank
== 2)
2876 if (matrix_b
->rank
== 1)
2888 /* Vector * Transpose(B) not handled yet. */
2898 ns
= insert_block ();
2900 /* Assign the type of the zero expression for initializing the resulting
2901 array, and the expression (+ and * for real, integer and complex;
2902 .and. and .or for logical. */
2904 switch(expr1
->ts
.type
)
2907 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2908 op_times
= INTRINSIC_TIMES
;
2909 op_plus
= INTRINSIC_PLUS
;
2913 op_times
= INTRINSIC_AND
;
2914 op_plus
= INTRINSIC_OR
;
2915 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2919 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2921 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2922 op_times
= INTRINSIC_TIMES
;
2923 op_plus
= INTRINSIC_PLUS
;
2927 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2929 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2930 op_times
= INTRINSIC_TIMES
;
2931 op_plus
= INTRINSIC_PLUS
;
2939 current_code
= &ns
->code
;
2941 /* Freeze the references, keeping track of how many temporary variables were
2944 freeze_references (matrix_a
);
2945 freeze_references (matrix_b
);
2946 freeze_references (expr1
);
2949 next_code_point
= current_code
;
2952 next_code_point
= &ns
->code
;
2953 for (i
=0; i
<n_vars
; i
++)
2954 next_code_point
= &(*next_code_point
)->next
;
2957 /* Take care of the inline flag. If the limit check evaluates to a
2958 constant, dead code elimination will eliminate the unneeded branch. */
2960 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2962 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2964 /* Insert the original statement into the else branch. */
2965 if_limit
->block
->block
->next
= co
;
2968 /* ... and the new ones go into the original one. */
2969 *next_code_point
= if_limit
;
2970 next_code_point
= &if_limit
->block
->next
;
2973 assign_zero
= XCNEW (gfc_code
);
2974 assign_zero
->op
= EXEC_ASSIGN
;
2975 assign_zero
->loc
= co
->loc
;
2976 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2977 assign_zero
->expr2
= zero_e
;
2979 /* Handle the reallocation, if needed. */
2980 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2982 gfc_code
*lhs_alloc
;
2984 /* Only need to check a single dimension for the A2B2 case for
2985 bounds checking, the rest will be allocated. */
2987 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2992 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2993 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2994 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2995 "in MATMUL intrinsic: Is %ld, should be %ld");
2996 *next_code_point
= test
;
2997 next_code_point
= &test
->next
;
3001 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3003 *next_code_point
= lhs_alloc
;
3004 next_code_point
= &lhs_alloc
->next
;
3007 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3010 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3012 if (m_case
== A2B2
|| m_case
== A2B1
)
3014 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3015 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3016 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3017 "in MATMUL intrinsic: Is %ld, should be %ld");
3018 *next_code_point
= test
;
3019 next_code_point
= &test
->next
;
3021 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3022 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3025 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3026 "MATMUL intrinsic for dimension 1: "
3027 "is %ld, should be %ld");
3028 else if (m_case
== A2B1
)
3029 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3030 "MATMUL intrinsic: "
3031 "is %ld, should be %ld");
3034 *next_code_point
= test
;
3035 next_code_point
= &test
->next
;
3037 else if (m_case
== A1B2
)
3039 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3040 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3041 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3042 "in MATMUL intrinsic: Is %ld, should be %ld");
3043 *next_code_point
= test
;
3044 next_code_point
= &test
->next
;
3046 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3047 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3049 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3050 "MATMUL intrinsic: "
3051 "is %ld, should be %ld");
3053 *next_code_point
= test
;
3054 next_code_point
= &test
->next
;
3059 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3060 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3061 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3062 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3064 *next_code_point
= test
;
3065 next_code_point
= &test
->next
;
3068 if (m_case
== A2B2T
)
3070 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3071 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3072 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3073 "MATMUL intrinsic for dimension 1: "
3074 "is %ld, should be %ld");
3076 *next_code_point
= test
;
3077 next_code_point
= &test
->next
;
3079 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3080 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3081 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3082 "MATMUL intrinsic for dimension 2: "
3083 "is %ld, should be %ld");
3084 *next_code_point
= test
;
3085 next_code_point
= &test
->next
;
3087 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3088 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3090 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3091 "MATMUL intrnisic for dimension 2: "
3092 "is %ld, should be %ld");
3093 *next_code_point
= test
;
3094 next_code_point
= &test
->next
;
3099 *next_code_point
= assign_zero
;
3101 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3103 assign_matmul
= XCNEW (gfc_code
);
3104 assign_matmul
->op
= EXEC_ASSIGN
;
3105 assign_matmul
->loc
= co
->loc
;
3107 /* Get the bounds for the loops, create them and create the scalarized
3113 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3115 u1
= get_size_m1 (matrix_b
, 2);
3116 u2
= get_size_m1 (matrix_a
, 2);
3117 u3
= get_size_m1 (matrix_a
, 1);
3119 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3120 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3121 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3123 do_1
->block
->next
= do_2
;
3124 do_2
->block
->next
= do_3
;
3125 do_3
->block
->next
= assign_matmul
;
3127 var_1
= do_1
->ext
.iterator
->var
;
3128 var_2
= do_2
->ext
.iterator
->var
;
3129 var_3
= do_3
->ext
.iterator
->var
;
3133 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3137 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3141 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3146 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3148 u1
= get_size_m1 (matrix_b
, 1);
3149 u2
= get_size_m1 (matrix_a
, 2);
3150 u3
= get_size_m1 (matrix_a
, 1);
3152 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3153 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3154 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3156 do_1
->block
->next
= do_2
;
3157 do_2
->block
->next
= do_3
;
3158 do_3
->block
->next
= assign_matmul
;
3160 var_1
= do_1
->ext
.iterator
->var
;
3161 var_2
= do_2
->ext
.iterator
->var
;
3162 var_3
= do_3
->ext
.iterator
->var
;
3166 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3170 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3174 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3179 u1
= get_size_m1 (matrix_b
, 1);
3180 u2
= get_size_m1 (matrix_a
, 1);
3182 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3183 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3185 do_1
->block
->next
= do_2
;
3186 do_2
->block
->next
= assign_matmul
;
3188 var_1
= do_1
->ext
.iterator
->var
;
3189 var_2
= do_2
->ext
.iterator
->var
;
3192 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3196 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3199 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3204 u1
= get_size_m1 (matrix_b
, 2);
3205 u2
= get_size_m1 (matrix_a
, 1);
3207 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3208 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3210 do_1
->block
->next
= do_2
;
3211 do_2
->block
->next
= assign_matmul
;
3213 var_1
= do_1
->ext
.iterator
->var
;
3214 var_2
= do_2
->ext
.iterator
->var
;
3217 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3220 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3224 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3233 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3234 matrix_a
->where
, 1, ascalar
);
3237 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3238 matrix_b
->where
, 1, bscalar
);
3240 /* First loop comes after the zero assignment. */
3241 assign_zero
->next
= do_1
;
3243 /* Build the assignment expression in the loop. */
3244 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3246 mult
= get_operand (op_times
, ascalar
, bscalar
);
3247 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3249 /* If we don't want to keep the original statement around in
3250 the else branch, we can free it. */
3252 if (if_limit
== NULL
)
3253 gfc_free_statements(co
);
3257 gfc_free_expr (zero
);
3262 #define WALK_SUBEXPR(NODE) \
3265 result = gfc_expr_walker (&(NODE), exprfn, data); \
3270 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3272 /* Walk expression *E, calling EXPRFN on each expression in it. */
3275 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3279 int walk_subtrees
= 1;
3280 gfc_actual_arglist
*a
;
3284 int result
= exprfn (e
, &walk_subtrees
, data
);
3288 switch ((*e
)->expr_type
)
3291 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3292 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3295 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3296 WALK_SUBEXPR (a
->expr
);
3300 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3301 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3302 WALK_SUBEXPR (a
->expr
);
3305 case EXPR_STRUCTURE
:
3307 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3308 c
= gfc_constructor_next (c
))
3310 if (c
->iterator
== NULL
)
3311 WALK_SUBEXPR (c
->expr
);
3315 WALK_SUBEXPR (c
->expr
);
3317 WALK_SUBEXPR (c
->iterator
->var
);
3318 WALK_SUBEXPR (c
->iterator
->start
);
3319 WALK_SUBEXPR (c
->iterator
->end
);
3320 WALK_SUBEXPR (c
->iterator
->step
);
3324 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3327 /* Fall through to the variable case in order to walk the
3330 case EXPR_SUBSTRING
:
3332 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3341 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3343 for (i
=0; i
< ar
->dimen
; i
++)
3345 WALK_SUBEXPR (ar
->start
[i
]);
3346 WALK_SUBEXPR (ar
->end
[i
]);
3347 WALK_SUBEXPR (ar
->stride
[i
]);
3354 WALK_SUBEXPR (r
->u
.ss
.start
);
3355 WALK_SUBEXPR (r
->u
.ss
.end
);
3371 #define WALK_SUBCODE(NODE) \
3374 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3380 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3381 on each expression in it. If any of the hooks returns non-zero, that
3382 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3383 no subcodes or subexpressions are traversed. */
3386 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3389 for (; *c
; c
= &(*c
)->next
)
3391 int walk_subtrees
= 1;
3392 int result
= codefn (c
, &walk_subtrees
, data
);
3399 gfc_actual_arglist
*a
;
3401 gfc_association_list
*alist
;
3402 bool saved_in_omp_workshare
;
3403 bool saved_in_where
;
3405 /* There might be statement insertions before the current code,
3406 which must not affect the expression walker. */
3409 saved_in_omp_workshare
= in_omp_workshare
;
3410 saved_in_where
= in_where
;
3416 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3417 if (co
->ext
.block
.assoc
)
3419 bool saved_in_assoc_list
= in_assoc_list
;
3421 in_assoc_list
= true;
3422 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3423 WALK_SUBEXPR (alist
->target
);
3425 in_assoc_list
= saved_in_assoc_list
;
3432 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3433 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3434 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3435 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3443 case EXEC_ASSIGN_CALL
:
3444 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3445 WALK_SUBEXPR (a
->expr
);
3449 WALK_SUBEXPR (co
->expr1
);
3450 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3451 WALK_SUBEXPR (a
->expr
);
3455 WALK_SUBEXPR (co
->expr1
);
3456 for (b
= co
->block
; b
; b
= b
->block
)
3459 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3461 WALK_SUBEXPR (cp
->low
);
3462 WALK_SUBEXPR (cp
->high
);
3464 WALK_SUBCODE (b
->next
);
3469 case EXEC_DEALLOCATE
:
3472 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3473 WALK_SUBEXPR (a
->expr
);
3478 case EXEC_DO_CONCURRENT
:
3480 gfc_forall_iterator
*fa
;
3481 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3483 WALK_SUBEXPR (fa
->var
);
3484 WALK_SUBEXPR (fa
->start
);
3485 WALK_SUBEXPR (fa
->end
);
3486 WALK_SUBEXPR (fa
->stride
);
3488 if (co
->op
== EXEC_FORALL
)
3494 WALK_SUBEXPR (co
->ext
.open
->unit
);
3495 WALK_SUBEXPR (co
->ext
.open
->file
);
3496 WALK_SUBEXPR (co
->ext
.open
->status
);
3497 WALK_SUBEXPR (co
->ext
.open
->access
);
3498 WALK_SUBEXPR (co
->ext
.open
->form
);
3499 WALK_SUBEXPR (co
->ext
.open
->recl
);
3500 WALK_SUBEXPR (co
->ext
.open
->blank
);
3501 WALK_SUBEXPR (co
->ext
.open
->position
);
3502 WALK_SUBEXPR (co
->ext
.open
->action
);
3503 WALK_SUBEXPR (co
->ext
.open
->delim
);
3504 WALK_SUBEXPR (co
->ext
.open
->pad
);
3505 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3506 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3507 WALK_SUBEXPR (co
->ext
.open
->convert
);
3508 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3509 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3510 WALK_SUBEXPR (co
->ext
.open
->round
);
3511 WALK_SUBEXPR (co
->ext
.open
->sign
);
3512 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3513 WALK_SUBEXPR (co
->ext
.open
->id
);
3514 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3518 WALK_SUBEXPR (co
->ext
.close
->unit
);
3519 WALK_SUBEXPR (co
->ext
.close
->status
);
3520 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3521 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3524 case EXEC_BACKSPACE
:
3528 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3529 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3530 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3534 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3535 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3536 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3537 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3538 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3539 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3540 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3541 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3542 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3543 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3544 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3545 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3546 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3547 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3548 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3549 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3550 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3551 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3552 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3553 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3554 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3555 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3556 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3557 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3558 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3559 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3560 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3561 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3562 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3563 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3564 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3565 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3566 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3567 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3568 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3569 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3573 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3574 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3575 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3576 WALK_SUBEXPR (co
->ext
.wait
->id
);
3581 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3582 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3583 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3584 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3585 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3586 WALK_SUBEXPR (co
->ext
.dt
->size
);
3587 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3588 WALK_SUBEXPR (co
->ext
.dt
->id
);
3589 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3590 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3591 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3592 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3593 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3594 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3595 WALK_SUBEXPR (co
->ext
.dt
->round
);
3596 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3597 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3600 case EXEC_OMP_PARALLEL
:
3601 case EXEC_OMP_PARALLEL_DO
:
3602 case EXEC_OMP_PARALLEL_DO_SIMD
:
3603 case EXEC_OMP_PARALLEL_SECTIONS
:
3605 in_omp_workshare
= false;
3607 /* This goto serves as a shortcut to avoid code
3608 duplication or a larger if or switch statement. */
3609 goto check_omp_clauses
;
3611 case EXEC_OMP_WORKSHARE
:
3612 case EXEC_OMP_PARALLEL_WORKSHARE
:
3614 in_omp_workshare
= true;
3618 case EXEC_OMP_DISTRIBUTE
:
3619 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3620 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3621 case EXEC_OMP_DISTRIBUTE_SIMD
:
3623 case EXEC_OMP_DO_SIMD
:
3624 case EXEC_OMP_SECTIONS
:
3625 case EXEC_OMP_SINGLE
:
3626 case EXEC_OMP_END_SINGLE
:
3628 case EXEC_OMP_TARGET
:
3629 case EXEC_OMP_TARGET_DATA
:
3630 case EXEC_OMP_TARGET_TEAMS
:
3631 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3632 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3633 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3634 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3635 case EXEC_OMP_TARGET_UPDATE
:
3637 case EXEC_OMP_TEAMS
:
3638 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3639 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3640 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3641 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3643 /* Come to this label only from the
3644 EXEC_OMP_PARALLEL_* cases above. */
3648 if (co
->ext
.omp_clauses
)
3650 gfc_omp_namelist
*n
;
3651 static int list_types
[]
3652 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3653 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3655 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3656 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3657 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3658 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3659 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3660 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3661 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3662 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3663 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3664 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3666 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3668 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3670 WALK_SUBEXPR (n
->expr
);
3677 WALK_SUBEXPR (co
->expr1
);
3678 WALK_SUBEXPR (co
->expr2
);
3679 WALK_SUBEXPR (co
->expr3
);
3680 WALK_SUBEXPR (co
->expr4
);
3681 for (b
= co
->block
; b
; b
= b
->block
)
3683 WALK_SUBEXPR (b
->expr1
);
3684 WALK_SUBEXPR (b
->expr2
);
3685 WALK_SUBCODE (b
->next
);
3688 if (co
->op
== EXEC_FORALL
)
3691 if (co
->op
== EXEC_DO
)
3694 in_omp_workshare
= saved_in_omp_workshare
;
3695 in_where
= saved_in_where
;