1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2018 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 int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static int call_external_blas (gfc_code
**, int *, void *);
57 static bool has_dimen_vector_ref (gfc_expr
*);
58 static int matmul_temp_args (gfc_code
**, int *,void *data
);
59 static int index_interchange (gfc_code
**, int*, void *);
61 static bool is_fe_temp (gfc_expr
*e
);
64 static void check_locus (gfc_namespace
*);
67 /* How deep we are inside an argument list. */
69 static int count_arglist
;
71 /* Vector of gfc_expr ** we operate on. */
73 static vec
<gfc_expr
**> expr_array
;
75 /* Pointer to the gfc_code we currently work on - to be able to insert
76 a block before the statement. */
78 static gfc_code
**current_code
;
80 /* Pointer to the block to be inserted, and the statement we are
81 changing within the block. */
83 static gfc_code
*inserted_block
, **changed_statement
;
85 /* The namespace we are currently dealing with. */
87 static gfc_namespace
*current_ns
;
89 /* If we are within any forall loop. */
91 static int forall_level
;
93 /* Keep track of whether we are within an OMP workshare. */
95 static bool in_omp_workshare
;
97 /* Keep track of whether we are within a WHERE statement. */
101 /* Keep track of iterators for array constructors. */
103 static int iterator_level
;
105 /* Keep track of DO loop levels. */
113 static vec
<do_t
> doloop_list
;
114 static int doloop_level
;
116 /* Keep track of if and select case levels. */
119 static int select_level
;
121 /* Vector of gfc_expr * to keep track of DO loops. */
123 struct my_struct
*evec
;
125 /* Keep track of association lists. */
127 static bool in_assoc_list
;
129 /* Counter for temporary variables. */
131 static int var_num
= 1;
133 /* What sort of matrix we are dealing with when inlining MATMUL. */
135 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
137 /* Keep track of the number of expressions we have inserted so far
142 /* Entry point - run all passes for a namespace. */
145 gfc_run_passes (gfc_namespace
*ns
)
148 /* Warn about dubious DO loops where the index might
155 doloop_list
.release ();
162 gfc_get_errors (&w
, &e
);
166 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
167 optimize_namespace (ns
);
169 if (flag_frontend_optimize
)
171 optimize_reduction (ns
);
172 if (flag_dump_fortran_optimized
)
173 gfc_dump_parse_tree (ns
, stdout
);
175 expr_array
.release ();
178 if (flag_realloc_lhs
)
179 realloc_strings (ns
);
184 /* Callback function: Warn if there is no location information in a
188 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
189 void *data ATTRIBUTE_UNUSED
)
192 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
193 gfc_warning_internal (0, "Inconsistent internal state: "
194 "No location in statement");
200 /* Callback function: Warn if there is no location information in an
204 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
205 void *data ATTRIBUTE_UNUSED
)
208 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
209 gfc_warning_internal (0, "Inconsistent internal state: "
210 "No location in expression near %L",
211 &((*current_code
)->loc
));
215 /* Run check for missing location information. */
218 check_locus (gfc_namespace
*ns
)
220 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
222 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
224 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
231 /* Callback for each gfc_code node invoked from check_realloc_strings.
232 For an allocatable LHS string which also appears as a variable on
244 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
245 void *data ATTRIBUTE_UNUSED
)
247 gfc_expr
*expr1
, *expr2
;
253 if (co
->op
!= EXEC_ASSIGN
)
257 if (expr1
->ts
.type
!= BT_CHARACTER
258 || !gfc_expr_attr(expr1
).allocatable
259 || !expr1
->ts
.deferred
)
262 if (is_fe_temp (expr1
))
265 expr2
= gfc_discard_nops (co
->expr2
);
267 if (expr2
->expr_type
== EXPR_VARIABLE
)
269 found_substr
= false;
270 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
272 if (ref
->type
== REF_SUBSTRING
)
281 else if (expr2
->expr_type
!= EXPR_ARRAY
282 && (expr2
->expr_type
!= EXPR_OP
283 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
286 if (!gfc_check_dependency (expr1
, expr2
, true))
289 /* gfc_check_dependency doesn't always pick up identical expressions.
290 However, eliminating the above sends the compiler into an infinite
291 loop on valid expressions. Without this check, the gimplifier emits
292 an ICE for a = a, where a is deferred character length. */
293 if (!gfc_dep_compare_expr (expr1
, expr2
))
297 inserted_block
= NULL
;
298 changed_statement
= NULL
;
299 n
= create_var (expr2
, "realloc_string");
304 /* Callback for each gfc_code node invoked through gfc_code_walker
305 from optimize_namespace. */
308 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
309 void *data ATTRIBUTE_UNUSED
)
316 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
317 || op
== EXEC_CALL_PPC
)
323 inserted_block
= NULL
;
324 changed_statement
= NULL
;
326 if (op
== EXEC_ASSIGN
)
327 optimize_assignment (*c
);
331 /* Callback for each gfc_expr node invoked through gfc_code_walker
332 from optimize_namespace. */
335 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
336 void *data ATTRIBUTE_UNUSED
)
340 if ((*e
)->expr_type
== EXPR_FUNCTION
)
343 function_expr
= true;
346 function_expr
= false;
348 if (optimize_trim (*e
))
349 gfc_simplify_expr (*e
, 0);
351 if (optimize_lexical_comparison (*e
))
352 gfc_simplify_expr (*e
, 0);
354 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
355 gfc_simplify_expr (*e
, 0);
357 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
358 switch ((*e
)->value
.function
.isym
->id
)
360 case GFC_ISYM_MINLOC
:
361 case GFC_ISYM_MAXLOC
:
362 optimize_minmaxloc (e
);
374 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
375 function is a scalar, just copy it; otherwise returns the new element, the
376 old one can be freed. */
379 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
381 gfc_expr
*fcn
, *e
= c
->expr
;
383 fcn
= gfc_copy_expr (e
);
386 gfc_constructor_base newbase
;
388 gfc_constructor
*new_c
;
391 new_expr
= gfc_get_expr ();
392 new_expr
->expr_type
= EXPR_ARRAY
;
393 new_expr
->ts
= e
->ts
;
394 new_expr
->where
= e
->where
;
396 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
397 new_c
->iterator
= c
->iterator
;
398 new_expr
->value
.constructor
= newbase
;
406 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
408 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
409 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
410 fn
->value
.function
.isym
->name
,
411 fn
->where
, 3, fcn
, NULL
, NULL
);
412 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
413 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
414 fn
->value
.function
.isym
->name
,
415 fn
->where
, 2, fcn
, NULL
);
417 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
419 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
425 /* Callback function for optimzation of reductions to scalars. Transform ANY
426 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
427 correspondingly. Handly only the simple cases without MASK and DIM. */
430 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
431 void *data ATTRIBUTE_UNUSED
)
436 gfc_actual_arglist
*a
;
437 gfc_actual_arglist
*dim
;
439 gfc_expr
*res
, *new_expr
;
440 gfc_actual_arglist
*mask
;
444 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
445 || fn
->value
.function
.isym
== NULL
)
448 id
= fn
->value
.function
.isym
->id
;
450 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
451 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
454 a
= fn
->value
.function
.actual
;
456 /* Don't handle MASK or DIM. */
460 if (dim
->expr
!= NULL
)
463 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
466 if ( mask
->expr
!= NULL
)
472 if (arg
->expr_type
!= EXPR_ARRAY
)
481 case GFC_ISYM_PRODUCT
:
482 op
= INTRINSIC_TIMES
;
497 c
= gfc_constructor_first (arg
->value
.constructor
);
499 /* Don't do any simplififcation if we have
500 - no element in the constructor or
501 - only have a single element in the array which contains an
507 res
= copy_walk_reduction_arg (c
, fn
);
509 c
= gfc_constructor_next (c
);
512 new_expr
= gfc_get_expr ();
513 new_expr
->ts
= fn
->ts
;
514 new_expr
->expr_type
= EXPR_OP
;
515 new_expr
->rank
= fn
->rank
;
516 new_expr
->where
= fn
->where
;
517 new_expr
->value
.op
.op
= op
;
518 new_expr
->value
.op
.op1
= res
;
519 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
521 c
= gfc_constructor_next (c
);
524 gfc_simplify_expr (res
, 0);
531 /* Callback function for common function elimination, called from cfe_expr_0.
532 Put all eligible function expressions into expr_array. */
535 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
536 void *data ATTRIBUTE_UNUSED
)
539 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
542 /* We don't do character functions with unknown charlens. */
543 if ((*e
)->ts
.type
== BT_CHARACTER
544 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
545 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
548 /* We don't do function elimination within FORALL statements, it can
549 lead to wrong-code in certain circumstances. */
551 if (forall_level
> 0)
554 /* Function elimination inside an iterator could lead to functions which
555 depend on iterator variables being moved outside. FIXME: We should check
556 if the functions do indeed depend on the iterator variable. */
558 if (iterator_level
> 0)
561 /* If we don't know the shape at compile time, we create an allocatable
562 temporary variable to hold the intermediate result, but only if
563 allocation on assignment is active. */
565 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
568 /* Skip the test for pure functions if -faggressive-function-elimination
570 if ((*e
)->value
.function
.esym
)
572 /* Don't create an array temporary for elemental functions. */
573 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
576 /* Only eliminate potentially impure functions if the
577 user specifically requested it. */
578 if (!flag_aggressive_function_elimination
579 && !(*e
)->value
.function
.esym
->attr
.pure
580 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
584 if ((*e
)->value
.function
.isym
)
586 /* Conversions are handled on the fly by the middle end,
587 transpose during trans-* stages and TRANSFER by the middle end. */
588 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
589 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
590 || gfc_inline_intrinsic_function_p (*e
))
593 /* Don't create an array temporary for elemental functions,
594 as this would be wasteful of memory.
595 FIXME: Create a scalar temporary during scalarization. */
596 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
599 if (!(*e
)->value
.function
.isym
->pure
)
603 expr_array
.safe_push (e
);
607 /* Auxiliary function to check if an expression is a temporary created by
611 is_fe_temp (gfc_expr
*e
)
613 if (e
->expr_type
!= EXPR_VARIABLE
)
616 return e
->symtree
->n
.sym
->attr
.fe_temp
;
619 /* Determine the length of a string, if it can be evaluated as a constant
620 expression. Return a newly allocated gfc_expr or NULL on failure.
621 If the user specified a substring which is potentially longer than
622 the string itself, the string will be padded with spaces, which
626 constant_string_length (gfc_expr
*e
)
636 length
= e
->ts
.u
.cl
->length
;
637 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
638 return gfc_copy_expr(length
);
641 /* See if there is a substring. If it has a constant length, return
642 that and NULL otherwise. */
643 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
645 if (ref
->type
== REF_SUBSTRING
)
647 if (gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
649 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
652 mpz_add_ui (res
->value
.integer
, value
, 1);
661 /* Return length of char symbol, if constant. */
662 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
663 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
664 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
665 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
671 /* Insert a block at the current position unless it has already
672 been inserted; in this case use the one already there. */
674 static gfc_namespace
*
679 /* If the block hasn't already been created, do so. */
680 if (inserted_block
== NULL
)
682 inserted_block
= XCNEW (gfc_code
);
683 inserted_block
->op
= EXEC_BLOCK
;
684 inserted_block
->loc
= (*current_code
)->loc
;
685 ns
= gfc_build_block_ns (current_ns
);
686 inserted_block
->ext
.block
.ns
= ns
;
687 inserted_block
->ext
.block
.assoc
= NULL
;
689 ns
->code
= *current_code
;
691 /* If the statement has a label, make sure it is transferred to
692 the newly created block. */
694 if ((*current_code
)->here
)
696 inserted_block
->here
= (*current_code
)->here
;
697 (*current_code
)->here
= NULL
;
700 inserted_block
->next
= (*current_code
)->next
;
701 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
702 (*current_code
)->next
= NULL
;
703 /* Insert the BLOCK at the right position. */
704 *current_code
= inserted_block
;
705 ns
->parent
= current_ns
;
708 ns
= inserted_block
->ext
.block
.ns
;
714 /* Insert a call to the intrinsic len. Use a different name for
715 the symbol tree so we don't run into trouble when the user has
716 renamed len for some reason. */
719 get_len_call (gfc_expr
*str
)
722 gfc_actual_arglist
*actual_arglist
;
724 fcn
= gfc_get_expr ();
725 fcn
->expr_type
= EXPR_FUNCTION
;
726 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN
);
727 actual_arglist
= gfc_get_actual_arglist ();
728 actual_arglist
->expr
= str
;
730 fcn
->value
.function
.actual
= actual_arglist
;
731 fcn
->where
= str
->where
;
732 fcn
->ts
.type
= BT_INTEGER
;
733 fcn
->ts
.kind
= gfc_charlen_int_kind
;
735 gfc_get_sym_tree ("__internal_len", current_ns
, &fcn
->symtree
, false);
736 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
737 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
738 fcn
->symtree
->n
.sym
->attr
.function
= 1;
739 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
740 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
741 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
742 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
748 /* Returns a new expression (a variable) to be used in place of the old one,
749 with an optional assignment statement before the current statement to set
750 the value of the variable. Creates a new BLOCK for the statement if that
751 hasn't already been done and puts the statement, plus the newly created
752 variables, in that block. Special cases: If the expression is constant or
753 a temporary which has already been created, just copy it. */
756 create_var (gfc_expr
* e
, const char *vname
)
758 char name
[GFC_MAX_SYMBOL_LEN
+1];
759 gfc_symtree
*symtree
;
767 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
768 return gfc_copy_expr (e
);
770 /* Creation of an array of unknown size requires realloc on assignment.
771 If that is not possible, just return NULL. */
772 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
775 ns
= insert_block ();
778 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
780 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
782 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
785 symbol
= symtree
->n
.sym
;
790 symbol
->as
= gfc_get_array_spec ();
791 symbol
->as
->rank
= e
->rank
;
793 if (e
->shape
== NULL
)
795 /* We don't know the shape at compile time, so we use an
797 symbol
->as
->type
= AS_DEFERRED
;
798 symbol
->attr
.allocatable
= 1;
802 symbol
->as
->type
= AS_EXPLICIT
;
803 /* Copy the shape. */
804 for (i
=0; i
<e
->rank
; i
++)
808 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
810 mpz_set_si (p
->value
.integer
, 1);
811 symbol
->as
->lower
[i
] = p
;
813 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
815 mpz_set (q
->value
.integer
, e
->shape
[i
]);
816 symbol
->as
->upper
[i
] = q
;
822 if (e
->ts
.type
== BT_CHARACTER
)
826 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
827 length
= constant_string_length (e
);
829 symbol
->ts
.u
.cl
->length
= length
;
830 else if (e
->expr_type
== EXPR_VARIABLE
831 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
832 && e
->ts
.u
.cl
->length
)
833 symbol
->ts
.u
.cl
->length
= get_len_call (gfc_copy_expr (e
));
836 symbol
->attr
.allocatable
= 1;
837 symbol
->ts
.u
.cl
->length
= NULL
;
838 symbol
->ts
.deferred
= 1;
843 symbol
->attr
.flavor
= FL_VARIABLE
;
844 symbol
->attr
.referenced
= 1;
845 symbol
->attr
.dimension
= e
->rank
> 0;
846 symbol
->attr
.fe_temp
= 1;
847 gfc_commit_symbol (symbol
);
849 result
= gfc_get_expr ();
850 result
->expr_type
= EXPR_VARIABLE
;
851 result
->ts
= symbol
->ts
;
852 result
->ts
.deferred
= deferred
;
853 result
->rank
= e
->rank
;
854 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
855 result
->symtree
= symtree
;
856 result
->where
= e
->where
;
859 result
->ref
= gfc_get_ref ();
860 result
->ref
->type
= REF_ARRAY
;
861 result
->ref
->u
.ar
.type
= AR_FULL
;
862 result
->ref
->u
.ar
.where
= e
->where
;
863 result
->ref
->u
.ar
.dimen
= e
->rank
;
864 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
865 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
866 if (warn_array_temporaries
)
867 gfc_warning (OPT_Warray_temporaries
,
868 "Creating array temporary at %L", &(e
->where
));
871 /* Generate the new assignment. */
872 n
= XCNEW (gfc_code
);
874 n
->loc
= (*current_code
)->loc
;
875 n
->next
= *changed_statement
;
876 n
->expr1
= gfc_copy_expr (result
);
878 *changed_statement
= n
;
884 /* Warn about function elimination. */
887 do_warn_function_elimination (gfc_expr
*e
)
890 if (e
->expr_type
== EXPR_FUNCTION
891 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
894 gfc_warning (OPT_Wfunction_elimination
,
895 "Removing call to impure function %qs at %L", name
,
898 gfc_warning (OPT_Wfunction_elimination
,
899 "Removing call to impure function at %L",
905 /* Callback function for the code walker for doing common function
906 elimination. This builds up the list of functions in the expression
907 and goes through them to detect duplicates, which it then replaces
911 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
912 void *data ATTRIBUTE_UNUSED
)
918 /* Don't do this optimization within OMP workshare or ASSOC lists. */
920 if (in_omp_workshare
|| in_assoc_list
)
926 expr_array
.release ();
928 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
930 /* Walk through all the functions. */
932 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
934 /* Skip if the function has been replaced by a variable already. */
935 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
942 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
945 newvar
= create_var (*ei
, "fcn");
947 if (warn_function_elimination
)
948 do_warn_function_elimination (*ej
);
951 *ej
= gfc_copy_expr (newvar
);
958 /* We did all the necessary walking in this function. */
963 /* Callback function for common function elimination, called from
964 gfc_code_walker. This keeps track of the current code, in order
965 to insert statements as needed. */
968 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
971 inserted_block
= NULL
;
972 changed_statement
= NULL
;
974 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
975 and allocation on assigment are prohibited inside WHERE, and finally
976 masking an expression would lead to wrong-code when replacing
979 b = sum(foo(a) + foo(a))
990 if ((*c
)->op
== EXEC_WHERE
)
1000 /* Dummy function for expression call back, for use when we
1001 really don't want to do any walking. */
1004 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
1005 void *data ATTRIBUTE_UNUSED
)
1011 /* Dummy function for code callback, for use when we really
1012 don't want to do anything. */
1014 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
1015 int *walk_subtrees ATTRIBUTE_UNUSED
,
1016 void *data ATTRIBUTE_UNUSED
)
1021 /* Code callback function for converting
1028 This is because common function elimination would otherwise place the
1029 temporary variables outside the loop. */
1032 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1033 void *data ATTRIBUTE_UNUSED
)
1036 gfc_code
*c_if1
, *c_if2
, *c_exit
;
1037 gfc_code
*loopblock
;
1038 gfc_expr
*e_not
, *e_cond
;
1040 if (co
->op
!= EXEC_DO_WHILE
)
1043 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1048 /* Generate the condition of the if statement, which is .not. the original
1050 e_not
= gfc_get_expr ();
1051 e_not
->ts
= e_cond
->ts
;
1052 e_not
->where
= e_cond
->where
;
1053 e_not
->expr_type
= EXPR_OP
;
1054 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1055 e_not
->value
.op
.op1
= e_cond
;
1057 /* Generate the EXIT statement. */
1058 c_exit
= XCNEW (gfc_code
);
1059 c_exit
->op
= EXEC_EXIT
;
1060 c_exit
->ext
.which_construct
= co
;
1061 c_exit
->loc
= co
->loc
;
1063 /* Generate the IF statement. */
1064 c_if2
= XCNEW (gfc_code
);
1065 c_if2
->op
= EXEC_IF
;
1066 c_if2
->expr1
= e_not
;
1067 c_if2
->next
= c_exit
;
1068 c_if2
->loc
= co
->loc
;
1070 /* ... plus the one to chain it to. */
1071 c_if1
= XCNEW (gfc_code
);
1072 c_if1
->op
= EXEC_IF
;
1073 c_if1
->block
= c_if2
;
1074 c_if1
->loc
= co
->loc
;
1076 /* Make the DO WHILE loop into a DO block by replacing the condition
1077 with a true constant. */
1078 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1080 /* Hang the generated if statement into the loop body. */
1082 loopblock
= co
->block
->next
;
1083 co
->block
->next
= c_if1
;
1084 c_if1
->next
= loopblock
;
1089 /* Code callback function for converting
1102 because otherwise common function elimination would place the BLOCKs
1103 into the wrong place. */
1106 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1107 void *data ATTRIBUTE_UNUSED
)
1110 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1112 if (co
->op
!= EXEC_IF
)
1115 /* This loop starts out with the first ELSE statement. */
1116 else_stmt
= co
->block
->block
;
1118 while (else_stmt
!= NULL
)
1120 gfc_code
*next_else
;
1122 /* If there is no condition, we're done. */
1123 if (else_stmt
->expr1
== NULL
)
1126 next_else
= else_stmt
->block
;
1128 /* Generate the new IF statement. */
1129 c_if2
= XCNEW (gfc_code
);
1130 c_if2
->op
= EXEC_IF
;
1131 c_if2
->expr1
= else_stmt
->expr1
;
1132 c_if2
->next
= else_stmt
->next
;
1133 c_if2
->loc
= else_stmt
->loc
;
1134 c_if2
->block
= next_else
;
1136 /* ... plus the one to chain it to. */
1137 c_if1
= XCNEW (gfc_code
);
1138 c_if1
->op
= EXEC_IF
;
1139 c_if1
->block
= c_if2
;
1140 c_if1
->loc
= else_stmt
->loc
;
1142 /* Insert the new IF after the ELSE. */
1143 else_stmt
->expr1
= NULL
;
1144 else_stmt
->next
= c_if1
;
1145 else_stmt
->block
= NULL
;
1147 else_stmt
= next_else
;
1149 /* Don't walk subtrees. */
1153 /* Callback function to var_in_expr - return true if expr1 and
1154 expr2 are identical variables. */
1156 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1159 gfc_expr
*expr1
= (gfc_expr
*) data
;
1160 gfc_expr
*expr2
= *e
;
1162 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1165 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1168 /* Return true if expr1 is found in expr2. */
1171 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1173 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1175 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1180 struct do_stack
*prev
;
1185 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1186 optimize by replacing do loops with their analog array slices. For
1189 write (*,*) (a(i), i=1,4)
1193 write (*,*) a(1:4:1) . */
1196 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1199 gfc_expr
*new_e
, *expr
, *start
;
1201 struct do_stack ds_push
;
1202 int i
, future_rank
= 0;
1203 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1206 /* Find the first transfer/do statement. */
1207 for (curr
= code
; curr
; curr
= curr
->next
)
1209 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1213 /* Ensure it is the only transfer/do statement because cases like
1215 write (*,*) (a(i), b(i), i=1,4)
1217 cannot be optimized. */
1219 if (!curr
|| curr
->next
)
1222 if (curr
->op
== EXEC_DO
)
1224 if (curr
->ext
.iterator
->var
->ref
)
1226 ds_push
.prev
= stack_top
;
1227 ds_push
.iter
= curr
->ext
.iterator
;
1228 ds_push
.code
= curr
;
1229 stack_top
= &ds_push
;
1230 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1232 if (curr
!= stack_top
->code
&& !*has_reached
)
1234 curr
->block
->next
= NULL
;
1235 gfc_free_statements (curr
);
1238 *has_reached
= true;
1244 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1248 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1251 /* Find the iterators belonging to each variable and check conditions. */
1252 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1254 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1255 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1258 start
= ref
->u
.ar
.start
[i
];
1259 gfc_simplify_expr (start
, 0);
1260 switch (start
->expr_type
)
1264 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1268 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1269 if (!stack_top
|| !stack_top
->iter
1270 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1272 /* Check for (a(i,i), i=1,3). */
1276 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1283 iters
[i
] = stack_top
->iter
;
1284 stack_top
= stack_top
->prev
;
1292 switch (start
->value
.op
.op
)
1294 case INTRINSIC_PLUS
:
1295 case INTRINSIC_TIMES
:
1296 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1297 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1299 case INTRINSIC_MINUS
:
1300 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1301 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1302 || start
->value
.op
.op1
->ref
)
1304 if (!stack_top
|| !stack_top
->iter
1305 || stack_top
->iter
->var
->symtree
1306 != start
->value
.op
.op1
->symtree
)
1308 iters
[i
] = stack_top
->iter
;
1309 stack_top
= stack_top
->prev
;
1321 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1322 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1326 gfc_expr
*var
= iters
[i
]->var
;
1327 for (int j
= i
- 1; j
< i
; j
++)
1330 && (var_in_expr (var
, iters
[j
]->start
)
1331 || var_in_expr (var
, iters
[j
]->end
)
1332 || var_in_expr (var
, iters
[j
]->step
)))
1338 /* Create new expr. */
1339 new_e
= gfc_copy_expr (curr
->expr1
);
1340 new_e
->expr_type
= EXPR_VARIABLE
;
1341 new_e
->rank
= future_rank
;
1342 if (curr
->expr1
->shape
)
1343 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1345 /* Assign new starts, ends and strides if necessary. */
1346 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1350 start
= ref
->u
.ar
.start
[i
];
1351 switch (start
->expr_type
)
1354 gfc_internal_error ("bad expression");
1357 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1358 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1359 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1360 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1361 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1362 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1365 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1366 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1367 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1368 expr
= gfc_copy_expr (start
);
1369 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1370 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1371 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1372 expr
= gfc_copy_expr (start
);
1373 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1374 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1375 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1376 switch (start
->value
.op
.op
)
1378 case INTRINSIC_MINUS
:
1379 case INTRINSIC_PLUS
:
1380 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1382 case INTRINSIC_TIMES
:
1383 expr
= gfc_copy_expr (start
);
1384 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1385 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1386 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1389 gfc_internal_error ("bad op");
1393 gfc_internal_error ("bad expression");
1396 curr
->expr1
= new_e
;
1398 /* Insert modified statement. Check whether the statement needs to be
1399 inserted at the lowest level. */
1400 if (!stack_top
->iter
)
1404 curr
->next
= prev
->next
->next
;
1409 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1410 stack_top
->code
->block
->next
= curr
;
1414 stack_top
->code
->block
->next
= curr
;
1418 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1419 tries to optimize its block. */
1422 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1423 void *data ATTRIBUTE_UNUSED
)
1425 gfc_code
**curr
, *prev
= NULL
;
1426 struct do_stack write
, first
;
1430 || ((*code
)->block
->op
!= EXEC_WRITE
1431 && (*code
)->block
->op
!= EXEC_READ
))
1439 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1441 if ((*curr
)->op
== EXEC_DO
)
1443 first
.prev
= &write
;
1444 first
.iter
= (*curr
)->ext
.iterator
;
1447 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1455 /* Optimize a namespace, including all contained namespaces.
1456 flag_frontend_optimize and flag_fronend_loop_interchange are
1457 handled separately. */
1460 optimize_namespace (gfc_namespace
*ns
)
1462 gfc_namespace
*saved_ns
= gfc_current_ns
;
1464 gfc_current_ns
= ns
;
1467 in_assoc_list
= false;
1468 in_omp_workshare
= false;
1470 if (flag_frontend_optimize
)
1472 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1473 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1474 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1475 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1476 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1477 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1483 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1488 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1492 if (flag_external_blas
)
1493 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1496 if (flag_inline_matmul_limit
!= 0)
1497 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1501 if (flag_frontend_loop_interchange
)
1502 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1505 /* BLOCKs are handled in the expression walker below. */
1506 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1508 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1509 optimize_namespace (ns
);
1511 gfc_current_ns
= saved_ns
;
1514 /* Handle dependencies for allocatable strings which potentially redefine
1515 themselves in an assignment. */
1518 realloc_strings (gfc_namespace
*ns
)
1521 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1523 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1525 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1526 realloc_strings (ns
);
1532 optimize_reduction (gfc_namespace
*ns
)
1535 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1536 callback_reduction
, NULL
);
1538 /* BLOCKs are handled in the expression walker below. */
1539 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1541 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1542 optimize_reduction (ns
);
1546 /* Replace code like
1549 a = matmul(b,c) ; a = a + d
1550 where the array function is not elemental and not allocatable
1551 and does not depend on the left-hand side.
1555 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1563 if (e
->expr_type
== EXPR_OP
)
1565 switch (e
->value
.op
.op
)
1567 /* Unary operators and exponentiation: Only look at a single
1570 case INTRINSIC_UPLUS
:
1571 case INTRINSIC_UMINUS
:
1572 case INTRINSIC_PARENTHESES
:
1573 case INTRINSIC_POWER
:
1574 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1578 case INTRINSIC_CONCAT
:
1579 /* Do not do string concatenations. */
1583 /* Binary operators. */
1584 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1587 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1593 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1594 && ! (e
->value
.function
.esym
1595 && (e
->value
.function
.esym
->attr
.elemental
1596 || e
->value
.function
.esym
->attr
.allocatable
1597 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1598 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1599 && ! (e
->value
.function
.isym
1600 && (e
->value
.function
.isym
->elemental
1601 || e
->ts
.type
!= c
->expr1
->ts
.type
1602 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1603 && ! gfc_inline_intrinsic_function_p (e
))
1609 /* Insert a new assignment statement after the current one. */
1610 n
= XCNEW (gfc_code
);
1611 n
->op
= EXEC_ASSIGN
;
1616 n
->expr1
= gfc_copy_expr (c
->expr1
);
1617 n
->expr2
= c
->expr2
;
1618 new_expr
= gfc_copy_expr (c
->expr1
);
1626 /* Nothing to optimize. */
1630 /* Remove unneeded TRIMs at the end of expressions. */
1633 remove_trim (gfc_expr
*rhs
)
1641 /* Check for a // b // trim(c). Looping is probably not
1642 necessary because the parser usually generates
1643 (// (// a b ) trim(c) ) , but better safe than sorry. */
1645 while (rhs
->expr_type
== EXPR_OP
1646 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1647 rhs
= rhs
->value
.op
.op2
;
1649 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1650 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1652 strip_function_call (rhs
);
1653 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1661 /* Optimizations for an assignment. */
1664 optimize_assignment (gfc_code
* c
)
1666 gfc_expr
*lhs
, *rhs
;
1671 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1673 /* Optimize a = trim(b) to a = b. */
1676 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1677 if (is_empty_string (rhs
))
1678 rhs
->value
.character
.length
= 0;
1681 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1682 optimize_binop_array_assignment (c
, &rhs
, false);
1686 /* Remove an unneeded function call, modifying the expression.
1687 This replaces the function call with the value of its
1688 first argument. The rest of the argument list is freed. */
1691 strip_function_call (gfc_expr
*e
)
1694 gfc_actual_arglist
*a
;
1696 a
= e
->value
.function
.actual
;
1698 /* We should have at least one argument. */
1699 gcc_assert (a
->expr
!= NULL
);
1703 /* Free the remaining arglist, if any. */
1705 gfc_free_actual_arglist (a
->next
);
1707 /* Graft the argument expression onto the original function. */
1713 /* Optimization of lexical comparison functions. */
1716 optimize_lexical_comparison (gfc_expr
*e
)
1718 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1721 switch (e
->value
.function
.isym
->id
)
1724 return optimize_comparison (e
, INTRINSIC_LE
);
1727 return optimize_comparison (e
, INTRINSIC_GE
);
1730 return optimize_comparison (e
, INTRINSIC_GT
);
1733 return optimize_comparison (e
, INTRINSIC_LT
);
1741 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1742 do CHARACTER because of possible pessimization involving character
1746 combine_array_constructor (gfc_expr
*e
)
1749 gfc_expr
*op1
, *op2
;
1752 gfc_constructor
*c
, *new_c
;
1753 gfc_constructor_base oldbase
, newbase
;
1758 /* Array constructors have rank one. */
1762 /* Don't try to combine association lists, this makes no sense
1763 and leads to an ICE. */
1767 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1768 if (forall_level
> 0)
1771 /* Inside an iterator, things can get hairy; we are likely to create
1772 an invalid temporary variable. */
1773 if (iterator_level
> 0)
1776 /* WHERE also doesn't work. */
1780 op1
= e
->value
.op
.op1
;
1781 op2
= e
->value
.op
.op2
;
1786 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1787 scalar_first
= false;
1788 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1790 scalar_first
= true;
1791 op1
= e
->value
.op
.op2
;
1792 op2
= e
->value
.op
.op1
;
1797 if (op2
->ts
.type
== BT_CHARACTER
)
1800 /* This might be an expanded constructor with very many constant values. If
1801 we perform the operation here, we might end up with a long compile time
1802 and actually longer execution time, so a length bound is in order here.
1803 If the constructor constains something which is not a constant, it did
1804 not come from an expansion, so leave it alone. */
1806 #define CONSTR_LEN_MAX 4
1808 oldbase
= op1
->value
.constructor
;
1812 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1814 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1822 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1825 #undef CONSTR_LEN_MAX
1828 e
->expr_type
= EXPR_ARRAY
;
1830 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1832 for (c
= gfc_constructor_first (oldbase
); c
;
1833 c
= gfc_constructor_next (c
))
1835 new_expr
= gfc_get_expr ();
1836 new_expr
->ts
= e
->ts
;
1837 new_expr
->expr_type
= EXPR_OP
;
1838 new_expr
->rank
= c
->expr
->rank
;
1839 new_expr
->where
= c
->expr
->where
;
1840 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1844 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1845 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1849 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1850 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1853 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1854 new_c
->iterator
= c
->iterator
;
1858 gfc_free_expr (op1
);
1859 gfc_free_expr (op2
);
1860 gfc_free_expr (scalar
);
1862 e
->value
.constructor
= newbase
;
1866 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1867 2**k into ishift(1,k) */
1870 optimize_power (gfc_expr
*e
)
1872 gfc_expr
*op1
, *op2
;
1873 gfc_expr
*iand
, *ishft
;
1875 if (e
->ts
.type
!= BT_INTEGER
)
1878 op1
= e
->value
.op
.op1
;
1880 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1883 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1885 gfc_free_expr (op1
);
1887 op2
= e
->value
.op
.op2
;
1892 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1893 "_internal_iand", e
->where
, 2, op2
,
1894 gfc_get_int_expr (e
->ts
.kind
,
1897 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1898 "_internal_ishft", e
->where
, 2, iand
,
1899 gfc_get_int_expr (e
->ts
.kind
,
1902 e
->value
.op
.op
= INTRINSIC_MINUS
;
1903 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1904 e
->value
.op
.op2
= ishft
;
1907 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1909 gfc_free_expr (op1
);
1911 op2
= e
->value
.op
.op2
;
1915 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1916 "_internal_ishft", e
->where
, 2,
1917 gfc_get_int_expr (e
->ts
.kind
,
1924 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1926 op2
= e
->value
.op
.op2
;
1930 gfc_free_expr (op1
);
1931 gfc_free_expr (op2
);
1933 e
->expr_type
= EXPR_CONSTANT
;
1934 e
->value
.op
.op1
= NULL
;
1935 e
->value
.op
.op2
= NULL
;
1936 mpz_init_set_si (e
->value
.integer
, 1);
1937 /* Typespec and location are still OK. */
1944 /* Recursive optimization of operators. */
1947 optimize_op (gfc_expr
*e
)
1951 gfc_intrinsic_op op
= e
->value
.op
.op
;
1955 /* Only use new-style comparisons. */
1958 case INTRINSIC_EQ_OS
:
1962 case INTRINSIC_GE_OS
:
1966 case INTRINSIC_LE_OS
:
1970 case INTRINSIC_NE_OS
:
1974 case INTRINSIC_GT_OS
:
1978 case INTRINSIC_LT_OS
:
1994 changed
= optimize_comparison (e
, op
);
1997 /* Look at array constructors. */
1998 case INTRINSIC_PLUS
:
1999 case INTRINSIC_MINUS
:
2000 case INTRINSIC_TIMES
:
2001 case INTRINSIC_DIVIDE
:
2002 return combine_array_constructor (e
) || changed
;
2004 case INTRINSIC_POWER
:
2005 return optimize_power (e
);
2015 /* Return true if a constant string contains only blanks. */
2018 is_empty_string (gfc_expr
*e
)
2022 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
2025 for (i
=0; i
< e
->value
.character
.length
; i
++)
2027 if (e
->value
.character
.string
[i
] != ' ')
2035 /* Insert a call to the intrinsic len_trim. Use a different name for
2036 the symbol tree so we don't run into trouble when the user has
2037 renamed len_trim for some reason. */
2040 get_len_trim_call (gfc_expr
*str
, int kind
)
2043 gfc_actual_arglist
*actual_arglist
, *next
;
2045 fcn
= gfc_get_expr ();
2046 fcn
->expr_type
= EXPR_FUNCTION
;
2047 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
2048 actual_arglist
= gfc_get_actual_arglist ();
2049 actual_arglist
->expr
= str
;
2050 next
= gfc_get_actual_arglist ();
2051 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
2052 actual_arglist
->next
= next
;
2054 fcn
->value
.function
.actual
= actual_arglist
;
2055 fcn
->where
= str
->where
;
2056 fcn
->ts
.type
= BT_INTEGER
;
2057 fcn
->ts
.kind
= gfc_charlen_int_kind
;
2059 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
2060 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
2061 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
2062 fcn
->symtree
->n
.sym
->attr
.function
= 1;
2063 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
2064 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
2065 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
2066 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
2072 /* Optimize expressions for equality. */
2075 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
2077 gfc_expr
*op1
, *op2
;
2081 gfc_actual_arglist
*firstarg
, *secondarg
;
2083 if (e
->expr_type
== EXPR_OP
)
2087 op1
= e
->value
.op
.op1
;
2088 op2
= e
->value
.op
.op2
;
2090 else if (e
->expr_type
== EXPR_FUNCTION
)
2092 /* One of the lexical comparison functions. */
2093 firstarg
= e
->value
.function
.actual
;
2094 secondarg
= firstarg
->next
;
2095 op1
= firstarg
->expr
;
2096 op2
= secondarg
->expr
;
2101 /* Strip off unneeded TRIM calls from string comparisons. */
2103 change
= remove_trim (op1
);
2105 if (remove_trim (op2
))
2108 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2109 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2110 handles them well). However, there are also cases that need a non-scalar
2111 argument. For example the any intrinsic. See PR 45380. */
2115 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2117 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2118 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2120 bool empty_op1
, empty_op2
;
2121 empty_op1
= is_empty_string (op1
);
2122 empty_op2
= is_empty_string (op2
);
2124 if (empty_op1
|| empty_op2
)
2130 /* This can only happen when an error for comparing
2131 characters of different kinds has already been issued. */
2132 if (empty_op1
&& empty_op2
)
2135 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2136 str
= empty_op1
? op2
: op1
;
2138 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2142 gfc_free_expr (op1
);
2144 gfc_free_expr (op2
);
2148 e
->value
.op
.op1
= fcn
;
2149 e
->value
.op
.op2
= zero
;
2154 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2156 if (flag_finite_math_only
2157 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2158 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2160 eq
= gfc_dep_compare_expr (op1
, op2
);
2163 /* Replace A // B < A // C with B < C, and A // B < C // B
2165 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2166 && op1
->expr_type
== EXPR_OP
2167 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2168 && op2
->expr_type
== EXPR_OP
2169 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2171 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2172 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2173 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2174 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2176 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2178 /* Watch out for 'A ' // x vs. 'A' // x. */
2180 if (op1_left
->expr_type
== EXPR_CONSTANT
2181 && op2_left
->expr_type
== EXPR_CONSTANT
2182 && op1_left
->value
.character
.length
2183 != op2_left
->value
.character
.length
)
2191 firstarg
->expr
= op1_right
;
2192 secondarg
->expr
= op2_right
;
2196 e
->value
.op
.op1
= op1_right
;
2197 e
->value
.op
.op2
= op2_right
;
2199 optimize_comparison (e
, op
);
2203 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2209 firstarg
->expr
= op1_left
;
2210 secondarg
->expr
= op2_left
;
2214 e
->value
.op
.op1
= op1_left
;
2215 e
->value
.op
.op2
= op2_left
;
2218 optimize_comparison (e
, op
);
2225 /* eq can only be -1, 0 or 1 at this point. */
2253 gfc_internal_error ("illegal OP in optimize_comparison");
2257 /* Replace the expression by a constant expression. The typespec
2258 and where remains the way it is. */
2261 e
->expr_type
= EXPR_CONSTANT
;
2262 e
->value
.logical
= result
;
2270 /* Optimize a trim function by replacing it with an equivalent substring
2271 involving a call to len_trim. This only works for expressions where
2272 variables are trimmed. Return true if anything was modified. */
2275 optimize_trim (gfc_expr
*e
)
2280 gfc_ref
**rr
= NULL
;
2282 /* Don't do this optimization within an argument list, because
2283 otherwise aliasing issues may occur. */
2285 if (count_arglist
!= 1)
2288 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2289 || e
->value
.function
.isym
== NULL
2290 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2293 a
= e
->value
.function
.actual
->expr
;
2295 if (a
->expr_type
!= EXPR_VARIABLE
)
2298 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2300 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2303 /* Follow all references to find the correct place to put the newly
2304 created reference. FIXME: Also handle substring references and
2305 array references. Array references cause strange regressions at
2310 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2312 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2317 strip_function_call (e
);
2322 /* Create the reference. */
2324 ref
= gfc_get_ref ();
2325 ref
->type
= REF_SUBSTRING
;
2327 /* Set the start of the reference. */
2329 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2331 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2333 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2335 /* Set the end of the reference to the call to len_trim. */
2337 ref
->u
.ss
.end
= fcn
;
2338 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2343 /* Optimize minloc(b), where b is rank 1 array, into
2344 (/ minloc(b, dim=1) /), and similarly for maxloc,
2345 as the latter forms are expanded inline. */
2348 optimize_minmaxloc (gfc_expr
**e
)
2351 gfc_actual_arglist
*a
;
2355 || fn
->value
.function
.actual
== NULL
2356 || fn
->value
.function
.actual
->expr
== NULL
2357 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2360 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2361 (*e
)->shape
= fn
->shape
;
2364 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2366 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2367 strcpy (name
, fn
->value
.function
.name
);
2368 p
= strstr (name
, "loc0");
2370 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2371 if (fn
->value
.function
.actual
->next
)
2373 a
= fn
->value
.function
.actual
->next
;
2374 gcc_assert (a
->expr
== NULL
);
2378 a
= gfc_get_actual_arglist ();
2379 fn
->value
.function
.actual
->next
= a
;
2381 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2383 mpz_set_ui (a
->expr
->value
.integer
, 1);
2386 /* Callback function for code checking that we do not pass a DO variable to an
2387 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2390 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2391 void *data ATTRIBUTE_UNUSED
)
2395 gfc_formal_arglist
*f
;
2396 gfc_actual_arglist
*a
;
2403 /* If the doloop_list grew, we have to truncate it here. */
2405 if ((unsigned) doloop_level
< doloop_list
.length())
2406 doloop_list
.truncate (doloop_level
);
2413 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2418 loop
.branch_level
= if_level
+ select_level
;
2419 loop
.seen_goto
= false;
2420 doloop_list
.safe_push (loop
);
2423 /* If anything could transfer control away from a suspicious
2424 subscript, make sure to set seen_goto in the current DO loop
2429 case EXEC_ERROR_STOP
:
2435 if (co
->ext
.open
->err
)
2440 if (co
->ext
.close
->err
)
2444 case EXEC_BACKSPACE
:
2449 if (co
->ext
.filepos
->err
)
2454 if (co
->ext
.filepos
->err
)
2460 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2465 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2466 loop
.seen_goto
= true;
2471 if (co
->resolved_sym
== NULL
)
2474 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2476 /* Withot a formal arglist, there is only unknown INTENT,
2477 which we don't check for. */
2485 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2493 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2495 if (a
->expr
&& a
->expr
->symtree
2496 && a
->expr
->symtree
->n
.sym
== do_sym
)
2498 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2499 gfc_error_now ("Variable %qs at %L set to undefined "
2500 "value inside loop beginning at %L as "
2501 "INTENT(OUT) argument to subroutine %qs",
2502 do_sym
->name
, &a
->expr
->where
,
2503 &(doloop_list
[i
].c
->loc
),
2504 co
->symtree
->n
.sym
->name
);
2505 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2506 gfc_error_now ("Variable %qs at %L not definable inside "
2507 "loop beginning at %L as INTENT(INOUT) "
2508 "argument to subroutine %qs",
2509 do_sym
->name
, &a
->expr
->where
,
2510 &(doloop_list
[i
].c
->loc
),
2511 co
->symtree
->n
.sym
->name
);
2522 if (seen_goto
&& doloop_level
> 0)
2523 doloop_list
[doloop_level
-1].seen_goto
= true;
2528 /* Callback function to warn about different things within DO loops. */
2531 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2532 void *data ATTRIBUTE_UNUSED
)
2536 if (doloop_list
.length () == 0)
2539 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2542 last
= &doloop_list
.last();
2543 if (last
->seen_goto
&& !warn_do_subscript
)
2546 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2558 /* Callback function - if the expression is the variable in data->sym,
2559 replace it with a constant from data->val. */
2562 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2569 if (ex
->expr_type
!= EXPR_VARIABLE
)
2572 d
= (insert_index_t
*) data
;
2573 if (ex
->symtree
->n
.sym
!= d
->sym
)
2576 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2577 mpz_set (n
->value
.integer
, d
->val
);
2584 /* In the expression e, replace occurrences of the variable sym with
2585 val. If this results in a constant expression, return true and
2586 return the value in ret. Return false if the expression already
2587 is a constant. Caller has to clear ret in that case. */
2590 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2593 insert_index_t data
;
2596 if (e
->expr_type
== EXPR_CONSTANT
)
2599 n
= gfc_copy_expr (e
);
2601 mpz_init_set (data
.val
, val
);
2602 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2603 gfc_simplify_expr (n
, 0);
2605 if (n
->expr_type
== EXPR_CONSTANT
)
2608 mpz_init_set (ret
, n
->value
.integer
);
2613 mpz_clear (data
.val
);
2619 /* Check array subscripts for possible out-of-bounds accesses in DO
2620 loops with constant bounds. */
2623 do_subscript (gfc_expr
**e
)
2633 /* Constants are already checked. */
2634 if (v
->expr_type
== EXPR_CONSTANT
)
2637 /* Wrong warnings will be generated in an associate list. */
2641 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2643 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2646 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2649 mpz_t do_start
, do_step
, do_end
;
2650 bool have_do_start
, have_do_end
;
2651 bool error_not_proven
;
2658 /* If we are within a branch, or a goto or equivalent
2659 was seen in the DO loop before, then we cannot prove that
2660 this expression is actually evaluated. Don't do anything
2661 unless we want to see it all. */
2662 error_not_proven
= lp
->seen_goto
2663 || lp
->branch_level
< if_level
+ select_level
;
2665 if (error_not_proven
&& !warn_do_subscript
)
2668 if (error_not_proven
)
2669 warn
= OPT_Wdo_subscript
;
2673 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2674 if (do_sym
->ts
.type
!= BT_INTEGER
)
2677 /* If we do not know about the stepsize, the loop may be zero trip.
2678 Do not warn in this case. */
2680 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2681 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2685 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2687 have_do_start
= true;
2688 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2691 have_do_start
= false;
2694 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2697 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2700 have_do_end
= false;
2702 if (!have_do_start
&& !have_do_end
)
2705 /* May have to correct the end value if the step does not equal
2707 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2713 mpz_sub (diff
, do_end
, do_start
);
2714 mpz_tdiv_r (rem
, diff
, do_step
);
2715 mpz_sub (do_end
, do_end
, rem
);
2720 for (i
= 0; i
< ar
->dimen
; i
++)
2723 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2724 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2726 if (ar
->as
->lower
[i
]
2727 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2728 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2729 gfc_warning (warn
, "Array reference at %L out of bounds "
2730 "(%ld < %ld) in loop beginning at %L",
2731 &ar
->start
[i
]->where
, mpz_get_si (val
),
2732 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2733 &doloop_list
[j
].c
->loc
);
2735 if (ar
->as
->upper
[i
]
2736 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2737 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2738 gfc_warning (warn
, "Array reference at %L out of bounds "
2739 "(%ld > %ld) in loop beginning at %L",
2740 &ar
->start
[i
]->where
, mpz_get_si (val
),
2741 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2742 &doloop_list
[j
].c
->loc
);
2747 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2748 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2750 if (ar
->as
->lower
[i
]
2751 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2752 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2753 gfc_warning (warn
, "Array reference at %L out of bounds "
2754 "(%ld < %ld) in loop beginning at %L",
2755 &ar
->start
[i
]->where
, mpz_get_si (val
),
2756 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2757 &doloop_list
[j
].c
->loc
);
2759 if (ar
->as
->upper
[i
]
2760 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2761 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2762 gfc_warning (warn
, "Array reference at %L out of bounds "
2763 "(%ld > %ld) in loop beginning at %L",
2764 &ar
->start
[i
]->where
, mpz_get_si (val
),
2765 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2766 &doloop_list
[j
].c
->loc
);
2776 /* Function for functions checking that we do not pass a DO variable
2777 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2780 do_intent (gfc_expr
**e
)
2782 gfc_formal_arglist
*f
;
2783 gfc_actual_arglist
*a
;
2790 if (expr
->expr_type
!= EXPR_FUNCTION
)
2793 /* Intrinsic functions don't modify their arguments. */
2795 if (expr
->value
.function
.isym
)
2798 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2800 /* Without a formal arglist, there is only unknown INTENT,
2801 which we don't check for. */
2805 a
= expr
->value
.function
.actual
;
2809 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2816 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2818 if (a
->expr
&& a
->expr
->symtree
2819 && a
->expr
->symtree
->n
.sym
== do_sym
)
2821 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2822 gfc_error_now ("Variable %qs at %L set to undefined value "
2823 "inside loop beginning at %L as INTENT(OUT) "
2824 "argument to function %qs", do_sym
->name
,
2825 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2826 expr
->symtree
->n
.sym
->name
);
2827 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2828 gfc_error_now ("Variable %qs at %L not definable inside loop"
2829 " beginning at %L as INTENT(INOUT) argument to"
2830 " function %qs", do_sym
->name
,
2831 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2832 expr
->symtree
->n
.sym
->name
);
2843 doloop_warn (gfc_namespace
*ns
)
2845 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2848 /* This selction deals with inlining calls to MATMUL. */
2850 /* Replace calls to matmul outside of straight assignments with a temporary
2851 variable so that later inlining will work. */
2854 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2858 bool *found
= (bool *) data
;
2862 if (e
->expr_type
!= EXPR_FUNCTION
2863 || e
->value
.function
.isym
== NULL
2864 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2867 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2868 || in_where
|| in_assoc_list
)
2871 /* Check if this is already in the form c = matmul(a,b). */
2873 if ((*current_code
)->expr2
== e
)
2876 n
= create_var (e
, "matmul");
2878 /* If create_var is unable to create a variable (for example if
2879 -fno-realloc-lhs is in force with a variable that does not have bounds
2880 known at compile-time), just return. */
2890 /* Set current_code and associated variables so that matmul_to_var_expr can
2894 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2895 void *data ATTRIBUTE_UNUSED
)
2897 if (current_code
!= c
)
2900 inserted_block
= NULL
;
2901 changed_statement
= NULL
;
2908 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2909 for a and b if there is a dependency between the arguments and the
2910 result variable or if a or b are the result of calculations that cannot
2911 be handled by the inliner. */
2914 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2915 void *data ATTRIBUTE_UNUSED
)
2917 gfc_expr
*expr1
, *expr2
;
2919 gfc_actual_arglist
*a
, *b
;
2921 gfc_expr
*matrix_a
, *matrix_b
;
2922 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2926 if (co
->op
!= EXEC_ASSIGN
)
2929 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2933 /* This has some duplication with inline_matmul_assign. This
2934 is because the creation of temporary variables could still fail,
2935 and inline_matmul_assign still needs to be able to handle these
2940 if (expr2
->expr_type
!= EXPR_FUNCTION
2941 || expr2
->value
.function
.isym
== NULL
2942 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2946 a
= expr2
->value
.function
.actual
;
2947 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2948 if (matrix_a
!= NULL
)
2950 if (matrix_a
->expr_type
== EXPR_VARIABLE
2951 && (gfc_check_dependency (matrix_a
, expr1
, true)
2952 || has_dimen_vector_ref (matrix_a
)))
2960 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2961 if (matrix_b
!= NULL
)
2963 if (matrix_b
->expr_type
== EXPR_VARIABLE
2964 && (gfc_check_dependency (matrix_b
, expr1
, true)
2965 || has_dimen_vector_ref (matrix_b
)))
2971 if (!a_tmp
&& !b_tmp
)
2975 inserted_block
= NULL
;
2976 changed_statement
= NULL
;
2980 at
= create_var (a
->expr
,"mma");
2987 bt
= create_var (b
->expr
,"mmb");
2994 /* Auxiliary function to build and simplify an array inquiry function.
2995 dim is zero-based. */
2998 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
3001 gfc_expr
*dim_arg
, *kind
;
3007 case GFC_ISYM_LBOUND
:
3008 name
= "_gfortran_lbound";
3011 case GFC_ISYM_UBOUND
:
3012 name
= "_gfortran_ubound";
3016 name
= "_gfortran_size";
3023 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
3025 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3028 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3029 gfc_index_integer_kind
);
3031 ec
= gfc_copy_expr (e
);
3033 /* No bounds checking, this will be done before the loops if -fcheck=bounds
3035 ec
->no_bounds_check
= 1;
3036 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
3038 gfc_simplify_expr (fcn
, 0);
3039 fcn
->no_bounds_check
= 1;
3043 /* Builds a logical expression. */
3046 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3051 ts
.type
= BT_LOGICAL
;
3052 ts
.kind
= gfc_default_logical_kind
;
3053 res
= gfc_get_expr ();
3054 res
->where
= e1
->where
;
3055 res
->expr_type
= EXPR_OP
;
3056 res
->value
.op
.op
= op
;
3057 res
->value
.op
.op1
= e1
;
3058 res
->value
.op
.op2
= e2
;
3065 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3066 compatible typespecs. */
3069 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3073 res
= gfc_get_expr ();
3075 res
->where
= e1
->where
;
3076 res
->expr_type
= EXPR_OP
;
3077 res
->value
.op
.op
= op
;
3078 res
->value
.op
.op1
= e1
;
3079 res
->value
.op
.op2
= e2
;
3080 gfc_simplify_expr (res
, 0);
3084 /* Generate the IF statement for a runtime check if we want to do inlining or
3085 not - putting in the code for both branches and putting it into the syntax
3086 tree is the caller's responsibility. For fixed array sizes, this should be
3087 removed by DCE. Only called for rank-two matrices A and B. */
3090 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3092 gfc_expr
*inline_limit
;
3093 gfc_code
*if_1
, *if_2
, *else_2
;
3094 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3098 /* Calculation is done in real to avoid integer overflow. */
3100 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3102 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3103 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3106 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3107 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3108 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3112 ts
.kind
= gfc_default_real_kind
;
3113 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3114 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3115 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3117 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3118 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3120 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3121 gfc_simplify_expr (cond
, 0);
3123 else_2
= XCNEW (gfc_code
);
3124 else_2
->op
= EXEC_IF
;
3125 else_2
->loc
= a
->where
;
3127 if_2
= XCNEW (gfc_code
);
3130 if_2
->loc
= a
->where
;
3131 if_2
->block
= else_2
;
3133 if_1
= XCNEW (gfc_code
);
3136 if_1
->loc
= a
->where
;
3142 /* Insert code to issue a runtime error if the expressions are not equal. */
3145 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3148 gfc_code
*if_1
, *if_2
;
3150 gfc_actual_arglist
*a1
, *a2
, *a3
;
3152 gcc_assert (e1
->where
.lb
);
3153 /* Build the call to runtime_error. */
3154 c
= XCNEW (gfc_code
);
3158 /* Get a null-terminated message string. */
3160 a1
= gfc_get_actual_arglist ();
3161 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3162 msg
, strlen(msg
)+1);
3165 /* Pass the value of the first expression. */
3166 a2
= gfc_get_actual_arglist ();
3167 a2
->expr
= gfc_copy_expr (e1
);
3170 /* Pass the value of the second expression. */
3171 a3
= gfc_get_actual_arglist ();
3172 a3
->expr
= gfc_copy_expr (e2
);
3175 gfc_check_fe_runtime_error (c
->ext
.actual
);
3176 gfc_resolve_fe_runtime_error (c
);
3178 if_2
= XCNEW (gfc_code
);
3180 if_2
->loc
= e1
->where
;
3183 if_1
= XCNEW (gfc_code
);
3186 if_1
->loc
= e1
->where
;
3188 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3189 gfc_simplify_expr (cond
, 0);
3195 /* Handle matrix reallocation. Caller is responsible to insert into
3198 For the two-dimensional case, build
3200 if (allocated(c)) then
3201 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3203 allocate (c(size(a,1), size(b,2)))
3206 allocate (c(size(a,1),size(b,2)))
3209 and for the other cases correspondingly.
3213 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3214 enum matrix_case m_case
)
3217 gfc_expr
*allocated
, *alloc_expr
;
3218 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3219 gfc_code
*else_alloc
;
3220 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3222 gfc_expr
*cond
, *ne1
, *ne2
;
3224 if (warn_realloc_lhs
)
3225 gfc_warning (OPT_Wrealloc_lhs
,
3226 "Code for reallocating the allocatable array at %L will "
3227 "be added", &c
->where
);
3229 alloc_expr
= gfc_copy_expr (c
);
3231 ar
= gfc_find_array_ref (alloc_expr
);
3232 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3234 /* c comes in as a full ref. Change it into a copy and make it into an
3235 element ref so it has the right form for for ALLOCATE. In the same
3236 switch statement, also generate the size comparison for the secod IF
3239 ar
->type
= AR_ELEMENT
;
3244 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3245 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3246 ne1
= build_logical_expr (INTRINSIC_NE
,
3247 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3248 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3249 ne2
= build_logical_expr (INTRINSIC_NE
,
3250 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3251 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3252 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3256 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3257 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3259 ne1
= build_logical_expr (INTRINSIC_NE
,
3260 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3261 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3262 ne2
= build_logical_expr (INTRINSIC_NE
,
3263 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3264 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3265 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3270 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3271 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3273 ne1
= build_logical_expr (INTRINSIC_NE
,
3274 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3275 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3276 ne2
= build_logical_expr (INTRINSIC_NE
,
3277 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3278 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3279 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3283 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3284 cond
= build_logical_expr (INTRINSIC_NE
,
3285 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3286 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3290 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3291 cond
= build_logical_expr (INTRINSIC_NE
,
3292 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3293 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3297 /* This can only happen for BLAS, we do not handle that case in
3299 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3300 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3302 ne1
= build_logical_expr (INTRINSIC_NE
,
3303 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3304 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3305 ne2
= build_logical_expr (INTRINSIC_NE
,
3306 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3307 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3309 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3317 gfc_simplify_expr (cond
, 0);
3319 /* We need two identical allocate statements in two
3320 branches of the IF statement. */
3322 allocate1
= XCNEW (gfc_code
);
3323 allocate1
->op
= EXEC_ALLOCATE
;
3324 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3325 allocate1
->loc
= c
->where
;
3326 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3328 allocate_else
= XCNEW (gfc_code
);
3329 allocate_else
->op
= EXEC_ALLOCATE
;
3330 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3331 allocate_else
->loc
= c
->where
;
3332 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3334 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3335 "_gfortran_allocated", c
->where
,
3336 1, gfc_copy_expr (c
));
3338 deallocate
= XCNEW (gfc_code
);
3339 deallocate
->op
= EXEC_DEALLOCATE
;
3340 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3341 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3342 deallocate
->next
= allocate1
;
3343 deallocate
->loc
= c
->where
;
3345 if_size_2
= XCNEW (gfc_code
);
3346 if_size_2
->op
= EXEC_IF
;
3347 if_size_2
->expr1
= cond
;
3348 if_size_2
->loc
= c
->where
;
3349 if_size_2
->next
= deallocate
;
3351 if_size_1
= XCNEW (gfc_code
);
3352 if_size_1
->op
= EXEC_IF
;
3353 if_size_1
->block
= if_size_2
;
3354 if_size_1
->loc
= c
->where
;
3356 else_alloc
= XCNEW (gfc_code
);
3357 else_alloc
->op
= EXEC_IF
;
3358 else_alloc
->loc
= c
->where
;
3359 else_alloc
->next
= allocate_else
;
3361 if_alloc_2
= XCNEW (gfc_code
);
3362 if_alloc_2
->op
= EXEC_IF
;
3363 if_alloc_2
->expr1
= allocated
;
3364 if_alloc_2
->loc
= c
->where
;
3365 if_alloc_2
->next
= if_size_1
;
3366 if_alloc_2
->block
= else_alloc
;
3368 if_alloc_1
= XCNEW (gfc_code
);
3369 if_alloc_1
->op
= EXEC_IF
;
3370 if_alloc_1
->block
= if_alloc_2
;
3371 if_alloc_1
->loc
= c
->where
;
3376 /* Callback function for has_function_or_op. */
3379 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3380 void *data ATTRIBUTE_UNUSED
)
3385 return (*e
)->expr_type
== EXPR_FUNCTION
3386 || (*e
)->expr_type
== EXPR_OP
;
3389 /* Returns true if the expression contains a function. */
3392 has_function_or_op (gfc_expr
**e
)
3397 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3400 /* Freeze (assign to a temporary variable) a single expression. */
3403 freeze_expr (gfc_expr
**ep
)
3406 if (has_function_or_op (ep
))
3408 ne
= create_var (*ep
, "freeze");
3413 /* Go through an expression's references and assign them to temporary
3414 variables if they contain functions. This is usually done prior to
3415 front-end scalarization to avoid multiple invocations of functions. */
3418 freeze_references (gfc_expr
*e
)
3424 for (r
=e
->ref
; r
; r
=r
->next
)
3426 if (r
->type
== REF_SUBSTRING
)
3428 if (r
->u
.ss
.start
!= NULL
)
3429 freeze_expr (&r
->u
.ss
.start
);
3431 if (r
->u
.ss
.end
!= NULL
)
3432 freeze_expr (&r
->u
.ss
.end
);
3434 else if (r
->type
== REF_ARRAY
)
3443 for (i
=0; i
<ar
->dimen
; i
++)
3445 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3447 freeze_expr (&ar
->start
[i
]);
3448 freeze_expr (&ar
->end
[i
]);
3449 freeze_expr (&ar
->stride
[i
]);
3451 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3453 freeze_expr (&ar
->start
[i
]);
3459 for (i
=0; i
<ar
->dimen
; i
++)
3460 freeze_expr (&ar
->start
[i
]);
3470 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3473 convert_to_index_kind (gfc_expr
*e
)
3477 gcc_assert (e
!= NULL
);
3479 res
= gfc_copy_expr (e
);
3481 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3483 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3487 ts
.type
= BT_INTEGER
;
3488 ts
.kind
= gfc_index_integer_kind
;
3490 gfc_convert_type_warn (e
, &ts
, 2, 0);
3496 /* Function to create a DO loop including creation of the
3497 iteration variable. gfc_expr are copied.*/
3500 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3501 gfc_namespace
*ns
, char *vname
)
3504 char name
[GFC_MAX_SYMBOL_LEN
+1];
3505 gfc_symtree
*symtree
;
3510 /* Create an expression for the iteration variable. */
3512 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3514 sprintf (name
, "__var_%d_do", var_num
++);
3517 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3520 /* Create the loop variable. */
3522 symbol
= symtree
->n
.sym
;
3523 symbol
->ts
.type
= BT_INTEGER
;
3524 symbol
->ts
.kind
= gfc_index_integer_kind
;
3525 symbol
->attr
.flavor
= FL_VARIABLE
;
3526 symbol
->attr
.referenced
= 1;
3527 symbol
->attr
.dimension
= 0;
3528 symbol
->attr
.fe_temp
= 1;
3529 gfc_commit_symbol (symbol
);
3531 i
= gfc_get_expr ();
3532 i
->expr_type
= EXPR_VARIABLE
;
3536 i
->symtree
= symtree
;
3538 /* ... and the nested DO statements. */
3539 n
= XCNEW (gfc_code
);
3542 n
->ext
.iterator
= gfc_get_iterator ();
3543 n
->ext
.iterator
->var
= i
;
3544 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3545 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3547 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3549 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3552 n2
= XCNEW (gfc_code
);
3560 /* Get the upper bound of the DO loops for matmul along a dimension. This
3564 get_size_m1 (gfc_expr
*e
, int dimen
)
3569 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3571 res
= gfc_get_constant_expr (BT_INTEGER
,
3572 gfc_index_integer_kind
, &e
->where
);
3573 mpz_sub_ui (res
->value
.integer
, size
, 1);
3578 res
= get_operand (INTRINSIC_MINUS
,
3579 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3580 gfc_get_int_expr (gfc_index_integer_kind
,
3582 gfc_simplify_expr (res
, 0);
3588 /* Function to return a scalarized expression. It is assumed that indices are
3589 zero based to make generation of DO loops easier. A zero as index will
3590 access the first element along a dimension. Single element references will
3591 be skipped. A NULL as an expression will be replaced by a full reference.
3592 This assumes that the index loops have gfc_index_integer_kind, and that all
3593 references have been frozen. */
3596 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3605 e
= gfc_copy_expr(e_in
);
3609 ar
= gfc_find_array_ref (e
);
3611 /* We scalarize count_index variables, reducing the rank by count_index. */
3613 e
->rank
= rank
- count_index
;
3615 was_fullref
= ar
->type
== AR_FULL
;
3618 ar
->type
= AR_ELEMENT
;
3620 ar
->type
= AR_SECTION
;
3622 /* Loop over the indices. For each index, create the expression
3623 index * stride + lbound(e, dim). */
3626 for (i
=0; i
< ar
->dimen
; i
++)
3628 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3630 if (index
[i_index
] != NULL
)
3632 gfc_expr
*lbound
, *nindex
;
3635 loopvar
= gfc_copy_expr (index
[i_index
]);
3641 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3642 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3646 ts
.type
= BT_INTEGER
;
3647 ts
.kind
= gfc_index_integer_kind
;
3648 gfc_convert_type (tmp
, &ts
, 2);
3650 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3655 /* Calculate the lower bound of the expression. */
3658 lbound
= gfc_copy_expr (ar
->start
[i
]);
3659 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3663 ts
.type
= BT_INTEGER
;
3664 ts
.kind
= gfc_index_integer_kind
;
3665 gfc_convert_type (lbound
, &ts
, 2);
3674 lbound_e
= gfc_copy_expr (e_in
);
3676 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3677 if (ref
->type
== REF_ARRAY
3678 && (ref
->u
.ar
.type
== AR_FULL
3679 || ref
->u
.ar
.type
== AR_SECTION
))
3684 gfc_free_ref_list (ref
->next
);
3690 /* Look at full individual sections, like a(:). The first index
3691 is the lbound of a full ref. */
3698 /* For assumed size, we need to keep around the final
3699 reference in order not to get an error on resolution
3700 below, and we cannot use AR_FULL. */
3702 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3704 ar
->type
= AR_SECTION
;
3713 for (j
= 0; j
< to
; j
++)
3715 gfc_free_expr (ar
->start
[j
]);
3716 ar
->start
[j
] = NULL
;
3717 gfc_free_expr (ar
->end
[j
]);
3719 gfc_free_expr (ar
->stride
[j
]);
3720 ar
->stride
[j
] = NULL
;
3723 /* We have to get rid of the shape, if there is one. Do
3724 so by freeing it and calling gfc_resolve to rebuild
3725 it, if necessary. */
3727 if (lbound_e
->shape
)
3728 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3730 lbound_e
->rank
= ar
->dimen
;
3731 gfc_resolve_expr (lbound_e
);
3733 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3735 gfc_free_expr (lbound_e
);
3738 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3740 gfc_free_expr (ar
->start
[i
]);
3741 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3743 gfc_free_expr (ar
->end
[i
]);
3745 gfc_free_expr (ar
->stride
[i
]);
3746 ar
->stride
[i
] = NULL
;
3747 gfc_simplify_expr (ar
->start
[i
], 0);
3749 else if (was_fullref
)
3751 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3757 /* Bounds checking will be done before the loops if -fcheck=bounds
3759 e
->no_bounds_check
= 1;
3763 /* Helper function to check for a dimen vector as subscript. */
3766 has_dimen_vector_ref (gfc_expr
*e
)
3771 ar
= gfc_find_array_ref (e
);
3773 if (ar
->type
== AR_FULL
)
3776 for (i
=0; i
<ar
->dimen
; i
++)
3777 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3783 /* If handed an expression of the form
3787 check if A can be handled by matmul and return if there is an uneven number
3788 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3789 otherwise. The caller has to check for the correct rank. */
3792 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3799 if (e
->expr_type
== EXPR_VARIABLE
)
3801 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3804 else if (e
->expr_type
== EXPR_FUNCTION
)
3806 if (e
->value
.function
.isym
== NULL
)
3809 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3811 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3812 *transpose
= !*transpose
;
3818 e
= e
->value
.function
.actual
->expr
;
3825 /* Macros for unified error messages. */
3827 #define B_ERROR(n) _("Incorrect extent in argument B in MATMUL intrinsic in " \
3828 "dimension " #n ": is %ld, should be %ld")
3830 #define C_ERROR(n) _("Array bound mismatch for dimension " #n " of array " \
3834 /* Inline assignments of the form c = matmul(a,b).
3835 Handle only the cases currently where b and c are rank-two arrays.
3837 This basically translates the code to
3843 do k=0, size(a, 2)-1
3844 do i=0, size(a, 1)-1
3845 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3846 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3847 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3848 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3857 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3858 void *data ATTRIBUTE_UNUSED
)
3861 gfc_expr
*expr1
, *expr2
;
3862 gfc_expr
*matrix_a
, *matrix_b
;
3863 gfc_actual_arglist
*a
, *b
;
3864 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3866 gfc_expr
*u1
, *u2
, *u3
;
3868 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3870 gfc_expr
*var_1
, *var_2
, *var_3
;
3873 gfc_intrinsic_op op_times
, op_plus
;
3874 enum matrix_case m_case
;
3876 gfc_code
*if_limit
= NULL
;
3877 gfc_code
**next_code_point
;
3878 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3881 if (co
->op
!= EXEC_ASSIGN
)
3884 if (in_where
|| in_assoc_list
)
3887 /* The BLOCKS generated for the temporary variables and FORALL don't
3889 if (forall_level
> 0)
3892 /* For now don't do anything in OpenMP workshare, it confuses
3893 its translation, which expects only the allowed statements in there.
3894 We should figure out how to parallelize this eventually. */
3895 if (in_omp_workshare
)
3900 if (expr2
->expr_type
!= EXPR_FUNCTION
3901 || expr2
->value
.function
.isym
== NULL
3902 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3906 inserted_block
= NULL
;
3907 changed_statement
= NULL
;
3909 a
= expr2
->value
.function
.actual
;
3910 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3911 if (matrix_a
== NULL
)
3915 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3916 if (matrix_b
== NULL
)
3919 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3920 || has_dimen_vector_ref (matrix_b
))
3923 /* We do not handle data dependencies yet. */
3924 if (gfc_check_dependency (expr1
, matrix_a
, true)
3925 || gfc_check_dependency (expr1
, matrix_b
, true))
3929 if (matrix_a
->rank
== 2)
3933 if (matrix_b
->rank
== 2 && !transpose_b
)
3938 if (matrix_b
->rank
== 1)
3940 else /* matrix_b->rank == 2 */
3949 else /* matrix_a->rank == 1 */
3951 if (matrix_b
->rank
== 2)
3961 ns
= insert_block ();
3963 /* Assign the type of the zero expression for initializing the resulting
3964 array, and the expression (+ and * for real, integer and complex;
3965 .and. and .or for logical. */
3967 switch(expr1
->ts
.type
)
3970 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3971 op_times
= INTRINSIC_TIMES
;
3972 op_plus
= INTRINSIC_PLUS
;
3976 op_times
= INTRINSIC_AND
;
3977 op_plus
= INTRINSIC_OR
;
3978 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3982 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3984 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3985 op_times
= INTRINSIC_TIMES
;
3986 op_plus
= INTRINSIC_PLUS
;
3990 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3992 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3993 op_times
= INTRINSIC_TIMES
;
3994 op_plus
= INTRINSIC_PLUS
;
4002 current_code
= &ns
->code
;
4004 /* Freeze the references, keeping track of how many temporary variables were
4007 freeze_references (matrix_a
);
4008 freeze_references (matrix_b
);
4009 freeze_references (expr1
);
4012 next_code_point
= current_code
;
4015 next_code_point
= &ns
->code
;
4016 for (i
=0; i
<n_vars
; i
++)
4017 next_code_point
= &(*next_code_point
)->next
;
4020 /* Take care of the inline flag. If the limit check evaluates to a
4021 constant, dead code elimination will eliminate the unneeded branch. */
4023 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
4024 && matrix_b
->rank
== 2)
4026 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
4027 flag_inline_matmul_limit
);
4029 /* Insert the original statement into the else branch. */
4030 if_limit
->block
->block
->next
= co
;
4033 /* ... and the new ones go into the original one. */
4034 *next_code_point
= if_limit
;
4035 next_code_point
= &if_limit
->block
->next
;
4038 zero_e
->no_bounds_check
= 1;
4040 assign_zero
= XCNEW (gfc_code
);
4041 assign_zero
->op
= EXEC_ASSIGN
;
4042 assign_zero
->loc
= co
->loc
;
4043 assign_zero
->expr1
= gfc_copy_expr (expr1
);
4044 assign_zero
->expr1
->no_bounds_check
= 1;
4045 assign_zero
->expr2
= zero_e
;
4047 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4049 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4052 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
4058 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4059 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4060 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4061 *next_code_point
= test
;
4062 next_code_point
= &test
->next
;
4066 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4067 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4068 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4069 *next_code_point
= test
;
4070 next_code_point
= &test
->next
;
4076 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4077 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4078 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4079 *next_code_point
= test
;
4080 next_code_point
= &test
->next
;
4084 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4085 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4086 test
= runtime_error_ne (c1
, b2
, C_ERROR(1));
4087 *next_code_point
= test
;
4088 next_code_point
= &test
->next
;
4094 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4095 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4096 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4097 *next_code_point
= test
;
4098 next_code_point
= &test
->next
;
4102 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4103 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4104 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4105 *next_code_point
= test
;
4106 next_code_point
= &test
->next
;
4108 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4109 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4110 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4111 *next_code_point
= test
;
4112 next_code_point
= &test
->next
;
4118 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4119 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4120 /* matrix_b is transposed, hence dimension 1 for the error message. */
4121 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4122 *next_code_point
= test
;
4123 next_code_point
= &test
->next
;
4127 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4128 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4129 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4130 *next_code_point
= test
;
4131 next_code_point
= &test
->next
;
4133 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4134 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4135 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4136 *next_code_point
= test
;
4137 next_code_point
= &test
->next
;
4143 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4144 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4145 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4146 *next_code_point
= test
;
4147 next_code_point
= &test
->next
;
4151 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4152 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4153 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4154 *next_code_point
= test
;
4155 next_code_point
= &test
->next
;
4157 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4158 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4159 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4160 *next_code_point
= test
;
4161 next_code_point
= &test
->next
;
4170 /* Handle the reallocation, if needed. */
4174 gfc_code
*lhs_alloc
;
4176 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4178 *next_code_point
= lhs_alloc
;
4179 next_code_point
= &lhs_alloc
->next
;
4183 *next_code_point
= assign_zero
;
4185 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4187 assign_matmul
= XCNEW (gfc_code
);
4188 assign_matmul
->op
= EXEC_ASSIGN
;
4189 assign_matmul
->loc
= co
->loc
;
4191 /* Get the bounds for the loops, create them and create the scalarized
4198 u1
= get_size_m1 (matrix_b
, 2);
4199 u2
= get_size_m1 (matrix_a
, 2);
4200 u3
= get_size_m1 (matrix_a
, 1);
4202 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4203 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4204 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4206 do_1
->block
->next
= do_2
;
4207 do_2
->block
->next
= do_3
;
4208 do_3
->block
->next
= assign_matmul
;
4210 var_1
= do_1
->ext
.iterator
->var
;
4211 var_2
= do_2
->ext
.iterator
->var
;
4212 var_3
= do_3
->ext
.iterator
->var
;
4216 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4220 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4224 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4230 u1
= get_size_m1 (matrix_b
, 1);
4231 u2
= get_size_m1 (matrix_a
, 2);
4232 u3
= get_size_m1 (matrix_a
, 1);
4234 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4235 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4236 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4238 do_1
->block
->next
= do_2
;
4239 do_2
->block
->next
= do_3
;
4240 do_3
->block
->next
= assign_matmul
;
4242 var_1
= do_1
->ext
.iterator
->var
;
4243 var_2
= do_2
->ext
.iterator
->var
;
4244 var_3
= do_3
->ext
.iterator
->var
;
4248 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4252 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4256 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4262 u1
= get_size_m1 (matrix_a
, 2);
4263 u2
= get_size_m1 (matrix_b
, 2);
4264 u3
= get_size_m1 (matrix_a
, 1);
4266 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4267 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4268 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4270 do_1
->block
->next
= do_2
;
4271 do_2
->block
->next
= do_3
;
4272 do_3
->block
->next
= assign_matmul
;
4274 var_1
= do_1
->ext
.iterator
->var
;
4275 var_2
= do_2
->ext
.iterator
->var
;
4276 var_3
= do_3
->ext
.iterator
->var
;
4280 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4284 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4288 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4293 u1
= get_size_m1 (matrix_b
, 1);
4294 u2
= get_size_m1 (matrix_a
, 1);
4296 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4297 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4299 do_1
->block
->next
= do_2
;
4300 do_2
->block
->next
= assign_matmul
;
4302 var_1
= do_1
->ext
.iterator
->var
;
4303 var_2
= do_2
->ext
.iterator
->var
;
4306 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4310 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4313 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4318 u1
= get_size_m1 (matrix_b
, 2);
4319 u2
= get_size_m1 (matrix_a
, 1);
4321 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4322 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4324 do_1
->block
->next
= do_2
;
4325 do_2
->block
->next
= assign_matmul
;
4327 var_1
= do_1
->ext
.iterator
->var
;
4328 var_2
= do_2
->ext
.iterator
->var
;
4331 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4334 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4338 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4346 /* Build the conjg call around the variables. Set the typespec manually
4347 because gfc_build_intrinsic_call sometimes gets this wrong. */
4352 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4353 matrix_a
->where
, 1, ascalar
);
4361 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4362 matrix_b
->where
, 1, bscalar
);
4365 /* First loop comes after the zero assignment. */
4366 assign_zero
->next
= do_1
;
4368 /* Build the assignment expression in the loop. */
4369 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4371 mult
= get_operand (op_times
, ascalar
, bscalar
);
4372 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4374 /* If we don't want to keep the original statement around in
4375 the else branch, we can free it. */
4377 if (if_limit
== NULL
)
4378 gfc_free_statements(co
);
4382 gfc_free_expr (zero
);
4387 /* Change matmul function calls in the form of
4391 to the corresponding call to a BLAS routine, if applicable. */
4394 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4395 void *data ATTRIBUTE_UNUSED
)
4397 gfc_code
*co
, *co_next
;
4398 gfc_expr
*expr1
, *expr2
;
4399 gfc_expr
*matrix_a
, *matrix_b
;
4400 gfc_code
*if_limit
= NULL
;
4401 gfc_actual_arglist
*a
, *b
;
4402 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4404 const char *blas_name
;
4405 const char *transa
, *transb
;
4406 gfc_expr
*c1
, *c2
, *b1
;
4407 gfc_actual_arglist
*actual
, *next
;
4410 enum matrix_case m_case
;
4412 gfc_code
**next_code_point
;
4414 /* Many of the tests for inline matmul also apply here. */
4418 if (co
->op
!= EXEC_ASSIGN
)
4421 if (in_where
|| in_assoc_list
)
4424 /* The BLOCKS generated for the temporary variables and FORALL don't
4426 if (forall_level
> 0)
4429 /* For now don't do anything in OpenMP workshare, it confuses
4430 its translation, which expects only the allowed statements in there. */
4432 if (in_omp_workshare
)
4437 if (expr2
->expr_type
!= EXPR_FUNCTION
4438 || expr2
->value
.function
.isym
== NULL
4439 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4442 type
= expr2
->ts
.type
;
4443 kind
= expr2
->ts
.kind
;
4445 /* Guard against recursion. */
4447 if (expr2
->external_blas
)
4450 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4453 if (type
== BT_REAL
)
4456 blas_name
= "sgemm";
4458 blas_name
= "dgemm";
4462 else if (type
== BT_COMPLEX
)
4465 blas_name
= "cgemm";
4467 blas_name
= "zgemm";
4474 a
= expr2
->value
.function
.actual
;
4475 if (a
->expr
->rank
!= 2)
4479 if (b
->expr
->rank
!= 2)
4482 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4483 if (matrix_a
== NULL
)
4496 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4497 if (matrix_b
== NULL
)
4526 inserted_block
= NULL
;
4527 changed_statement
= NULL
;
4529 expr2
->external_blas
= 1;
4531 /* We do not handle data dependencies yet. */
4532 if (gfc_check_dependency (expr1
, matrix_a
, true)
4533 || gfc_check_dependency (expr1
, matrix_b
, true))
4536 /* Generate the if statement and hang it into the tree. */
4537 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4539 (*current_code
) = if_limit
;
4541 if_limit
->block
->next
= co
;
4543 call
= XCNEW (gfc_code
);
4544 call
->loc
= co
->loc
;
4546 /* Bounds checking - a bit simpler than for inlining since we only
4547 have to take care of two-dimensional arrays here. */
4549 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4550 next_code_point
= &(if_limit
->block
->block
->next
);
4552 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4555 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4556 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4560 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4561 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4562 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4563 *next_code_point
= test
;
4564 next_code_point
= &test
->next
;
4568 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4569 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4570 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4571 *next_code_point
= test
;
4572 next_code_point
= &test
->next
;
4574 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4575 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4576 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4577 *next_code_point
= test
;
4578 next_code_point
= &test
->next
;
4584 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4585 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4586 /* matrix_b is transposed, hence dimension 1 for the error message. */
4587 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4588 *next_code_point
= test
;
4589 next_code_point
= &test
->next
;
4593 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4594 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4595 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4596 *next_code_point
= test
;
4597 next_code_point
= &test
->next
;
4599 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4600 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4601 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4602 *next_code_point
= test
;
4603 next_code_point
= &test
->next
;
4609 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4610 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4611 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4612 *next_code_point
= test
;
4613 next_code_point
= &test
->next
;
4617 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4618 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4619 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4620 *next_code_point
= test
;
4621 next_code_point
= &test
->next
;
4623 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4624 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4625 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4626 *next_code_point
= test
;
4627 next_code_point
= &test
->next
;
4632 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4633 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4634 test
= runtime_error_ne (b2
, a1
, B_ERROR(1));
4635 *next_code_point
= test
;
4636 next_code_point
= &test
->next
;
4640 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4641 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4642 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4643 *next_code_point
= test
;
4644 next_code_point
= &test
->next
;
4646 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4647 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4648 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4649 *next_code_point
= test
;
4650 next_code_point
= &test
->next
;
4659 /* Handle the reallocation, if needed. */
4663 gfc_code
*lhs_alloc
;
4665 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4666 *next_code_point
= lhs_alloc
;
4667 next_code_point
= &lhs_alloc
->next
;
4670 *next_code_point
= call
;
4671 if_limit
->next
= co_next
;
4673 /* Set up the BLAS call. */
4675 call
->op
= EXEC_CALL
;
4677 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4678 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4679 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4680 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4681 call
->resolved_sym
= call
->symtree
->n
.sym
;
4683 /* Argument TRANSA. */
4684 next
= gfc_get_actual_arglist ();
4685 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4688 call
->ext
.actual
= next
;
4690 /* Argument TRANSB. */
4692 next
= gfc_get_actual_arglist ();
4693 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4695 actual
->next
= next
;
4697 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4698 gfc_integer_4_kind
);
4699 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4700 gfc_integer_4_kind
);
4702 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4703 gfc_integer_4_kind
);
4707 next
= gfc_get_actual_arglist ();
4709 actual
->next
= next
;
4713 next
= gfc_get_actual_arglist ();
4715 actual
->next
= next
;
4719 next
= gfc_get_actual_arglist ();
4721 actual
->next
= next
;
4723 /* Argument ALPHA - set to one. */
4725 next
= gfc_get_actual_arglist ();
4726 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4727 if (type
== BT_REAL
)
4728 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4730 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4731 actual
->next
= next
;
4735 next
= gfc_get_actual_arglist ();
4736 next
->expr
= gfc_copy_expr (matrix_a
);
4737 actual
->next
= next
;
4741 next
= gfc_get_actual_arglist ();
4742 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4743 1, gfc_integer_4_kind
);
4744 actual
->next
= next
;
4748 next
= gfc_get_actual_arglist ();
4749 next
->expr
= gfc_copy_expr (matrix_b
);
4750 actual
->next
= next
;
4754 next
= gfc_get_actual_arglist ();
4755 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4756 1, gfc_integer_4_kind
);
4757 actual
->next
= next
;
4759 /* Argument BETA - set to zero. */
4761 next
= gfc_get_actual_arglist ();
4762 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4763 if (type
== BT_REAL
)
4764 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4766 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4767 actual
->next
= next
;
4772 next
= gfc_get_actual_arglist ();
4773 next
->expr
= gfc_copy_expr (expr1
);
4774 actual
->next
= next
;
4778 next
= gfc_get_actual_arglist ();
4779 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4780 1, gfc_integer_4_kind
);
4781 actual
->next
= next
;
4787 /* Code for index interchange for loops which are grouped together in DO
4788 CONCURRENT or FORALL statements. This is currently only applied if the
4789 iterations are grouped together in a single statement.
4791 For this transformation, it is assumed that memory access in strides is
4792 expensive, and that loops which access later indices (which access memory
4793 in bigger strides) should be moved to the first loops.
4795 For this, a loop over all the statements is executed, counting the times
4796 that the loop iteration values are accessed in each index. The loop
4797 indices are then sorted to minimize access to later indices from inner
4800 /* Type for holding index information. */
4804 gfc_forall_iterator
*fa
;
4806 int n
[GFC_MAX_DIMENSIONS
];
4809 /* Callback function to determine if an expression is the
4810 corresponding variable. */
4813 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4815 gfc_expr
*expr
= *e
;
4818 if (expr
->expr_type
!= EXPR_VARIABLE
)
4821 sym
= (gfc_symbol
*) data
;
4822 return sym
== expr
->symtree
->n
.sym
;
4825 /* Callback function to calculate the cost of a certain index. */
4828 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4838 if (expr
->expr_type
!= EXPR_VARIABLE
)
4842 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4844 if (ref
->type
== REF_ARRAY
)
4850 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4853 ind
= (ind_type
*) data
;
4854 for (i
= 0; i
< ar
->dimen
; i
++)
4856 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4858 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4865 /* Callback function for qsort, to sort the loop indices. */
4868 loop_comp (const void *e1
, const void *e2
)
4870 const ind_type
*i1
= (const ind_type
*) e1
;
4871 const ind_type
*i2
= (const ind_type
*) e2
;
4874 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4876 if (i1
->n
[i
] != i2
->n
[i
])
4877 return i1
->n
[i
] - i2
->n
[i
];
4879 /* All other things being equal, let's not change the ordering. */
4880 return i2
->num
- i1
->num
;
4883 /* Main function to do the index interchange. */
4886 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4887 void *data ATTRIBUTE_UNUSED
)
4892 gfc_forall_iterator
*fa
;
4896 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4900 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4903 /* Nothing to reorder. */
4907 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4910 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4912 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4914 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4919 ind
[n_iter
].sym
= NULL
;
4920 ind
[n_iter
].fa
= NULL
;
4922 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4923 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4925 /* Do the actual index interchange. */
4926 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4927 for (i
=1; i
<n_iter
; i
++)
4929 fa
->next
= ind
[i
].fa
;
4934 if (flag_warn_frontend_loop_interchange
)
4936 for (i
=1; i
<n_iter
; i
++)
4938 if (ind
[i
-1].num
> ind
[i
].num
)
4940 gfc_warning (OPT_Wfrontend_loop_interchange
,
4941 "Interchanging loops at %L", &co
->loc
);
4950 #define WALK_SUBEXPR(NODE) \
4953 result = gfc_expr_walker (&(NODE), exprfn, data); \
4958 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4960 /* Walk expression *E, calling EXPRFN on each expression in it. */
4963 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4967 int walk_subtrees
= 1;
4968 gfc_actual_arglist
*a
;
4972 int result
= exprfn (e
, &walk_subtrees
, data
);
4976 switch ((*e
)->expr_type
)
4979 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4980 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4983 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4984 WALK_SUBEXPR (a
->expr
);
4988 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4989 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4990 WALK_SUBEXPR (a
->expr
);
4993 case EXPR_STRUCTURE
:
4995 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4996 c
= gfc_constructor_next (c
))
4998 if (c
->iterator
== NULL
)
4999 WALK_SUBEXPR (c
->expr
);
5003 WALK_SUBEXPR (c
->expr
);
5005 WALK_SUBEXPR (c
->iterator
->var
);
5006 WALK_SUBEXPR (c
->iterator
->start
);
5007 WALK_SUBEXPR (c
->iterator
->end
);
5008 WALK_SUBEXPR (c
->iterator
->step
);
5012 if ((*e
)->expr_type
!= EXPR_ARRAY
)
5015 /* Fall through to the variable case in order to walk the
5019 case EXPR_SUBSTRING
:
5021 for (r
= (*e
)->ref
; r
; r
= r
->next
)
5030 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
5032 for (i
=0; i
< ar
->dimen
; i
++)
5034 WALK_SUBEXPR (ar
->start
[i
]);
5035 WALK_SUBEXPR (ar
->end
[i
]);
5036 WALK_SUBEXPR (ar
->stride
[i
]);
5043 WALK_SUBEXPR (r
->u
.ss
.start
);
5044 WALK_SUBEXPR (r
->u
.ss
.end
);
5061 #define WALK_SUBCODE(NODE) \
5064 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5070 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5071 on each expression in it. If any of the hooks returns non-zero, that
5072 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5073 no subcodes or subexpressions are traversed. */
5076 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5079 for (; *c
; c
= &(*c
)->next
)
5081 int walk_subtrees
= 1;
5082 int result
= codefn (c
, &walk_subtrees
, data
);
5089 gfc_actual_arglist
*a
;
5091 gfc_association_list
*alist
;
5092 bool saved_in_omp_workshare
;
5093 bool saved_in_where
;
5095 /* There might be statement insertions before the current code,
5096 which must not affect the expression walker. */
5099 saved_in_omp_workshare
= in_omp_workshare
;
5100 saved_in_where
= in_where
;
5106 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5107 if (co
->ext
.block
.assoc
)
5109 bool saved_in_assoc_list
= in_assoc_list
;
5111 in_assoc_list
= true;
5112 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5113 WALK_SUBEXPR (alist
->target
);
5115 in_assoc_list
= saved_in_assoc_list
;
5122 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5123 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5124 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5125 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5137 case EXEC_ASSIGN_CALL
:
5138 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5139 WALK_SUBEXPR (a
->expr
);
5143 WALK_SUBEXPR (co
->expr1
);
5144 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5145 WALK_SUBEXPR (a
->expr
);
5149 WALK_SUBEXPR (co
->expr1
);
5151 for (b
= co
->block
; b
; b
= b
->block
)
5154 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5156 WALK_SUBEXPR (cp
->low
);
5157 WALK_SUBEXPR (cp
->high
);
5159 WALK_SUBCODE (b
->next
);
5164 case EXEC_DEALLOCATE
:
5167 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5168 WALK_SUBEXPR (a
->expr
);
5173 case EXEC_DO_CONCURRENT
:
5175 gfc_forall_iterator
*fa
;
5176 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5178 WALK_SUBEXPR (fa
->var
);
5179 WALK_SUBEXPR (fa
->start
);
5180 WALK_SUBEXPR (fa
->end
);
5181 WALK_SUBEXPR (fa
->stride
);
5183 if (co
->op
== EXEC_FORALL
)
5189 WALK_SUBEXPR (co
->ext
.open
->unit
);
5190 WALK_SUBEXPR (co
->ext
.open
->file
);
5191 WALK_SUBEXPR (co
->ext
.open
->status
);
5192 WALK_SUBEXPR (co
->ext
.open
->access
);
5193 WALK_SUBEXPR (co
->ext
.open
->form
);
5194 WALK_SUBEXPR (co
->ext
.open
->recl
);
5195 WALK_SUBEXPR (co
->ext
.open
->blank
);
5196 WALK_SUBEXPR (co
->ext
.open
->position
);
5197 WALK_SUBEXPR (co
->ext
.open
->action
);
5198 WALK_SUBEXPR (co
->ext
.open
->delim
);
5199 WALK_SUBEXPR (co
->ext
.open
->pad
);
5200 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5201 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5202 WALK_SUBEXPR (co
->ext
.open
->convert
);
5203 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5204 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5205 WALK_SUBEXPR (co
->ext
.open
->round
);
5206 WALK_SUBEXPR (co
->ext
.open
->sign
);
5207 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5208 WALK_SUBEXPR (co
->ext
.open
->id
);
5209 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5210 WALK_SUBEXPR (co
->ext
.open
->share
);
5211 WALK_SUBEXPR (co
->ext
.open
->cc
);
5215 WALK_SUBEXPR (co
->ext
.close
->unit
);
5216 WALK_SUBEXPR (co
->ext
.close
->status
);
5217 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5218 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5221 case EXEC_BACKSPACE
:
5225 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5226 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5227 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5231 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5232 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5233 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5234 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5235 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5236 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5237 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5238 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5239 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5240 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5241 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5242 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5243 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5244 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5245 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5246 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5247 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5248 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5249 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5250 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5251 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5252 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5253 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5254 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5255 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5256 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5257 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5258 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5259 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5260 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5261 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5262 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5263 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5264 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5265 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5266 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5270 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5271 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5272 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5273 WALK_SUBEXPR (co
->ext
.wait
->id
);
5278 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5279 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5280 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5281 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5282 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5283 WALK_SUBEXPR (co
->ext
.dt
->size
);
5284 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5285 WALK_SUBEXPR (co
->ext
.dt
->id
);
5286 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5287 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5288 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5289 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5290 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5291 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5292 WALK_SUBEXPR (co
->ext
.dt
->round
);
5293 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5294 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5297 case EXEC_OMP_PARALLEL
:
5298 case EXEC_OMP_PARALLEL_DO
:
5299 case EXEC_OMP_PARALLEL_DO_SIMD
:
5300 case EXEC_OMP_PARALLEL_SECTIONS
:
5302 in_omp_workshare
= false;
5304 /* This goto serves as a shortcut to avoid code
5305 duplication or a larger if or switch statement. */
5306 goto check_omp_clauses
;
5308 case EXEC_OMP_WORKSHARE
:
5309 case EXEC_OMP_PARALLEL_WORKSHARE
:
5311 in_omp_workshare
= true;
5315 case EXEC_OMP_CRITICAL
:
5316 case EXEC_OMP_DISTRIBUTE
:
5317 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5318 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5319 case EXEC_OMP_DISTRIBUTE_SIMD
:
5321 case EXEC_OMP_DO_SIMD
:
5322 case EXEC_OMP_ORDERED
:
5323 case EXEC_OMP_SECTIONS
:
5324 case EXEC_OMP_SINGLE
:
5325 case EXEC_OMP_END_SINGLE
:
5327 case EXEC_OMP_TASKLOOP
:
5328 case EXEC_OMP_TASKLOOP_SIMD
:
5329 case EXEC_OMP_TARGET
:
5330 case EXEC_OMP_TARGET_DATA
:
5331 case EXEC_OMP_TARGET_ENTER_DATA
:
5332 case EXEC_OMP_TARGET_EXIT_DATA
:
5333 case EXEC_OMP_TARGET_PARALLEL
:
5334 case EXEC_OMP_TARGET_PARALLEL_DO
:
5335 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5336 case EXEC_OMP_TARGET_SIMD
:
5337 case EXEC_OMP_TARGET_TEAMS
:
5338 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5339 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5340 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5341 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5342 case EXEC_OMP_TARGET_UPDATE
:
5344 case EXEC_OMP_TEAMS
:
5345 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5346 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5347 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5348 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5350 /* Come to this label only from the
5351 EXEC_OMP_PARALLEL_* cases above. */
5355 if (co
->ext
.omp_clauses
)
5357 gfc_omp_namelist
*n
;
5358 static int list_types
[]
5359 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5360 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5362 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5363 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5364 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5365 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5366 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5367 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5368 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5369 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5370 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5371 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5372 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5373 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5374 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5375 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5376 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5377 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5379 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5381 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5383 WALK_SUBEXPR (n
->expr
);
5390 WALK_SUBEXPR (co
->expr1
);
5391 WALK_SUBEXPR (co
->expr2
);
5392 WALK_SUBEXPR (co
->expr3
);
5393 WALK_SUBEXPR (co
->expr4
);
5394 for (b
= co
->block
; b
; b
= b
->block
)
5396 WALK_SUBEXPR (b
->expr1
);
5397 WALK_SUBEXPR (b
->expr2
);
5398 WALK_SUBCODE (b
->next
);
5401 if (co
->op
== EXEC_FORALL
)
5404 if (co
->op
== EXEC_DO
)
5407 if (co
->op
== EXEC_IF
)
5410 if (co
->op
== EXEC_SELECT
)
5413 in_omp_workshare
= saved_in_omp_workshare
;
5414 in_where
= saved_in_where
;