1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2019 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 int matmul_temp_args (gfc_code
**, int *,void *data
);
58 static int index_interchange (gfc_code
**, int*, void *);
60 static bool is_fe_temp (gfc_expr
*e
);
63 static void check_locus (gfc_namespace
*);
66 /* How deep we are inside an argument list. */
68 static int count_arglist
;
70 /* Vector of gfc_expr ** we operate on. */
72 static vec
<gfc_expr
**> expr_array
;
74 /* Pointer to the gfc_code we currently work on - to be able to insert
75 a block before the statement. */
77 static gfc_code
**current_code
;
79 /* Pointer to the block to be inserted, and the statement we are
80 changing within the block. */
82 static gfc_code
*inserted_block
, **changed_statement
;
84 /* The namespace we are currently dealing with. */
86 static gfc_namespace
*current_ns
;
88 /* If we are within any forall loop. */
90 static int forall_level
;
92 /* Keep track of whether we are within an OMP workshare. */
94 static bool in_omp_workshare
;
96 /* Keep track of whether we are within a WHERE statement. */
100 /* Keep track of iterators for array constructors. */
102 static int iterator_level
;
104 /* Keep track of DO loop levels. */
112 static vec
<do_t
> doloop_list
;
113 static int doloop_level
;
115 /* Keep track of if and select case levels. */
118 static int select_level
;
120 /* Vector of gfc_expr * to keep track of DO loops. */
122 struct my_struct
*evec
;
124 /* Keep track of association lists. */
126 static bool in_assoc_list
;
128 /* Counter for temporary variables. */
130 static int var_num
= 1;
132 /* What sort of matrix we are dealing with when inlining MATMUL. */
134 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
136 /* Keep track of the number of expressions we have inserted so far
141 /* Entry point - run all passes for a namespace. */
144 gfc_run_passes (gfc_namespace
*ns
)
147 /* Warn about dubious DO loops where the index might
154 doloop_list
.release ();
161 gfc_get_errors (&w
, &e
);
165 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
166 optimize_namespace (ns
);
168 if (flag_frontend_optimize
)
170 optimize_reduction (ns
);
171 if (flag_dump_fortran_optimized
)
172 gfc_dump_parse_tree (ns
, stdout
);
174 expr_array
.release ();
177 if (flag_realloc_lhs
)
178 realloc_strings (ns
);
183 /* Callback function: Warn if there is no location information in a
187 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
188 void *data ATTRIBUTE_UNUSED
)
191 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
192 gfc_warning_internal (0, "Inconsistent internal state: "
193 "No location in statement");
199 /* Callback function: Warn if there is no location information in an
203 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
204 void *data ATTRIBUTE_UNUSED
)
207 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
208 gfc_warning_internal (0, "Inconsistent internal state: "
209 "No location in expression near %L",
210 &((*current_code
)->loc
));
214 /* Run check for missing location information. */
217 check_locus (gfc_namespace
*ns
)
219 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
221 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
223 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
230 /* Callback for each gfc_code node invoked from check_realloc_strings.
231 For an allocatable LHS string which also appears as a variable on
243 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
244 void *data ATTRIBUTE_UNUSED
)
246 gfc_expr
*expr1
, *expr2
;
252 if (co
->op
!= EXEC_ASSIGN
)
256 if (expr1
->ts
.type
!= BT_CHARACTER
257 || !gfc_expr_attr(expr1
).allocatable
258 || !expr1
->ts
.deferred
)
261 if (is_fe_temp (expr1
))
264 expr2
= gfc_discard_nops (co
->expr2
);
266 if (expr2
->expr_type
== EXPR_VARIABLE
)
268 found_substr
= false;
269 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
271 if (ref
->type
== REF_SUBSTRING
)
280 else if (expr2
->expr_type
!= EXPR_ARRAY
281 && (expr2
->expr_type
!= EXPR_OP
282 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
285 if (!gfc_check_dependency (expr1
, expr2
, true))
288 /* gfc_check_dependency doesn't always pick up identical expressions.
289 However, eliminating the above sends the compiler into an infinite
290 loop on valid expressions. Without this check, the gimplifier emits
291 an ICE for a = a, where a is deferred character length. */
292 if (!gfc_dep_compare_expr (expr1
, expr2
))
296 inserted_block
= NULL
;
297 changed_statement
= NULL
;
298 n
= create_var (expr2
, "realloc_string");
303 /* Callback for each gfc_code node invoked through gfc_code_walker
304 from optimize_namespace. */
307 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
308 void *data ATTRIBUTE_UNUSED
)
315 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
316 || op
== EXEC_CALL_PPC
)
322 inserted_block
= NULL
;
323 changed_statement
= NULL
;
325 if (op
== EXEC_ASSIGN
)
326 optimize_assignment (*c
);
330 /* Callback for each gfc_expr node invoked through gfc_code_walker
331 from optimize_namespace. */
334 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
335 void *data ATTRIBUTE_UNUSED
)
339 if ((*e
)->expr_type
== EXPR_FUNCTION
)
342 function_expr
= true;
345 function_expr
= false;
347 if (optimize_trim (*e
))
348 gfc_simplify_expr (*e
, 0);
350 if (optimize_lexical_comparison (*e
))
351 gfc_simplify_expr (*e
, 0);
353 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
354 gfc_simplify_expr (*e
, 0);
356 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
357 switch ((*e
)->value
.function
.isym
->id
)
359 case GFC_ISYM_MINLOC
:
360 case GFC_ISYM_MAXLOC
:
361 optimize_minmaxloc (e
);
373 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
374 function is a scalar, just copy it; otherwise returns the new element, the
375 old one can be freed. */
378 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
380 gfc_expr
*fcn
, *e
= c
->expr
;
382 fcn
= gfc_copy_expr (e
);
385 gfc_constructor_base newbase
;
387 gfc_constructor
*new_c
;
390 new_expr
= gfc_get_expr ();
391 new_expr
->expr_type
= EXPR_ARRAY
;
392 new_expr
->ts
= e
->ts
;
393 new_expr
->where
= e
->where
;
395 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
396 new_c
->iterator
= c
->iterator
;
397 new_expr
->value
.constructor
= newbase
;
405 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
407 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
408 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
409 fn
->value
.function
.isym
->name
,
410 fn
->where
, 3, fcn
, NULL
, NULL
);
411 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
412 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
413 fn
->value
.function
.isym
->name
,
414 fn
->where
, 2, fcn
, NULL
);
416 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
418 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
424 /* Callback function for optimzation of reductions to scalars. Transform ANY
425 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
426 correspondingly. Handly only the simple cases without MASK and DIM. */
429 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
430 void *data ATTRIBUTE_UNUSED
)
435 gfc_actual_arglist
*a
;
436 gfc_actual_arglist
*dim
;
438 gfc_expr
*res
, *new_expr
;
439 gfc_actual_arglist
*mask
;
443 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
444 || fn
->value
.function
.isym
== NULL
)
447 id
= fn
->value
.function
.isym
->id
;
449 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
450 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
453 a
= fn
->value
.function
.actual
;
455 /* Don't handle MASK or DIM. */
459 if (dim
->expr
!= NULL
)
462 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
465 if ( mask
->expr
!= NULL
)
471 if (arg
->expr_type
!= EXPR_ARRAY
)
480 case GFC_ISYM_PRODUCT
:
481 op
= INTRINSIC_TIMES
;
496 c
= gfc_constructor_first (arg
->value
.constructor
);
498 /* Don't do any simplififcation if we have
499 - no element in the constructor or
500 - only have a single element in the array which contains an
506 res
= copy_walk_reduction_arg (c
, fn
);
508 c
= gfc_constructor_next (c
);
511 new_expr
= gfc_get_expr ();
512 new_expr
->ts
= fn
->ts
;
513 new_expr
->expr_type
= EXPR_OP
;
514 new_expr
->rank
= fn
->rank
;
515 new_expr
->where
= fn
->where
;
516 new_expr
->value
.op
.op
= op
;
517 new_expr
->value
.op
.op1
= res
;
518 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
520 c
= gfc_constructor_next (c
);
523 gfc_simplify_expr (res
, 0);
530 /* Callback function for common function elimination, called from cfe_expr_0.
531 Put all eligible function expressions into expr_array. */
534 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
535 void *data ATTRIBUTE_UNUSED
)
538 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
541 /* We don't do character functions with unknown charlens. */
542 if ((*e
)->ts
.type
== BT_CHARACTER
543 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
544 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
547 /* We don't do function elimination within FORALL statements, it can
548 lead to wrong-code in certain circumstances. */
550 if (forall_level
> 0)
553 /* Function elimination inside an iterator could lead to functions which
554 depend on iterator variables being moved outside. FIXME: We should check
555 if the functions do indeed depend on the iterator variable. */
557 if (iterator_level
> 0)
560 /* If we don't know the shape at compile time, we create an allocatable
561 temporary variable to hold the intermediate result, but only if
562 allocation on assignment is active. */
564 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
567 /* Skip the test for pure functions if -faggressive-function-elimination
569 if ((*e
)->value
.function
.esym
)
571 /* Don't create an array temporary for elemental functions. */
572 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
575 /* Only eliminate potentially impure functions if the
576 user specifically requested it. */
577 if (!flag_aggressive_function_elimination
578 && !(*e
)->value
.function
.esym
->attr
.pure
579 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
583 if ((*e
)->value
.function
.isym
)
585 /* Conversions are handled on the fly by the middle end,
586 transpose during trans-* stages and TRANSFER by the middle end. */
587 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
588 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
589 || gfc_inline_intrinsic_function_p (*e
))
592 /* Don't create an array temporary for elemental functions,
593 as this would be wasteful of memory.
594 FIXME: Create a scalar temporary during scalarization. */
595 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
598 if (!(*e
)->value
.function
.isym
->pure
)
602 expr_array
.safe_push (e
);
606 /* Auxiliary function to check if an expression is a temporary created by
610 is_fe_temp (gfc_expr
*e
)
612 if (e
->expr_type
!= EXPR_VARIABLE
)
615 return e
->symtree
->n
.sym
->attr
.fe_temp
;
618 /* Determine the length of a string, if it can be evaluated as a constant
619 expression. Return a newly allocated gfc_expr or NULL on failure.
620 If the user specified a substring which is potentially longer than
621 the string itself, the string will be padded with spaces, which
625 constant_string_length (gfc_expr
*e
)
635 length
= e
->ts
.u
.cl
->length
;
636 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
637 return gfc_copy_expr(length
);
640 /* See if there is a substring. If it has a constant length, return
641 that and NULL otherwise. */
642 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
644 if (ref
->type
== REF_SUBSTRING
)
646 if (gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
648 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
651 mpz_add_ui (res
->value
.integer
, value
, 1);
660 /* Return length of char symbol, if constant. */
661 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
662 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
663 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
664 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
670 /* Insert a block at the current position unless it has already
671 been inserted; in this case use the one already there. */
673 static gfc_namespace
*
678 /* If the block hasn't already been created, do so. */
679 if (inserted_block
== NULL
)
681 inserted_block
= XCNEW (gfc_code
);
682 inserted_block
->op
= EXEC_BLOCK
;
683 inserted_block
->loc
= (*current_code
)->loc
;
684 ns
= gfc_build_block_ns (current_ns
);
685 inserted_block
->ext
.block
.ns
= ns
;
686 inserted_block
->ext
.block
.assoc
= NULL
;
688 ns
->code
= *current_code
;
690 /* If the statement has a label, make sure it is transferred to
691 the newly created block. */
693 if ((*current_code
)->here
)
695 inserted_block
->here
= (*current_code
)->here
;
696 (*current_code
)->here
= NULL
;
699 inserted_block
->next
= (*current_code
)->next
;
700 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
701 (*current_code
)->next
= NULL
;
702 /* Insert the BLOCK at the right position. */
703 *current_code
= inserted_block
;
704 ns
->parent
= current_ns
;
707 ns
= inserted_block
->ext
.block
.ns
;
713 /* Insert a call to the intrinsic len. Use a different name for
714 the symbol tree so we don't run into trouble when the user has
715 renamed len for some reason. */
718 get_len_call (gfc_expr
*str
)
721 gfc_actual_arglist
*actual_arglist
;
723 fcn
= gfc_get_expr ();
724 fcn
->expr_type
= EXPR_FUNCTION
;
725 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN
);
726 actual_arglist
= gfc_get_actual_arglist ();
727 actual_arglist
->expr
= str
;
729 fcn
->value
.function
.actual
= actual_arglist
;
730 fcn
->where
= str
->where
;
731 fcn
->ts
.type
= BT_INTEGER
;
732 fcn
->ts
.kind
= gfc_charlen_int_kind
;
734 gfc_get_sym_tree ("__internal_len", current_ns
, &fcn
->symtree
, false);
735 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
736 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
737 fcn
->symtree
->n
.sym
->attr
.function
= 1;
738 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
739 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
740 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
741 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
747 /* Returns a new expression (a variable) to be used in place of the old one,
748 with an optional assignment statement before the current statement to set
749 the value of the variable. Creates a new BLOCK for the statement if that
750 hasn't already been done and puts the statement, plus the newly created
751 variables, in that block. Special cases: If the expression is constant or
752 a temporary which has already been created, just copy it. */
755 create_var (gfc_expr
* e
, const char *vname
)
757 char name
[GFC_MAX_SYMBOL_LEN
+1];
758 gfc_symtree
*symtree
;
766 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
767 return gfc_copy_expr (e
);
769 /* Creation of an array of unknown size requires realloc on assignment.
770 If that is not possible, just return NULL. */
771 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
774 ns
= insert_block ();
777 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
779 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
781 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
784 symbol
= symtree
->n
.sym
;
789 symbol
->as
= gfc_get_array_spec ();
790 symbol
->as
->rank
= e
->rank
;
792 if (e
->shape
== NULL
)
794 /* We don't know the shape at compile time, so we use an
796 symbol
->as
->type
= AS_DEFERRED
;
797 symbol
->attr
.allocatable
= 1;
801 symbol
->as
->type
= AS_EXPLICIT
;
802 /* Copy the shape. */
803 for (i
=0; i
<e
->rank
; i
++)
807 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
809 mpz_set_si (p
->value
.integer
, 1);
810 symbol
->as
->lower
[i
] = p
;
812 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
814 mpz_set (q
->value
.integer
, e
->shape
[i
]);
815 symbol
->as
->upper
[i
] = q
;
821 if (e
->ts
.type
== BT_CHARACTER
)
825 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
826 length
= constant_string_length (e
);
828 symbol
->ts
.u
.cl
->length
= length
;
829 else if (e
->expr_type
== EXPR_VARIABLE
830 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
831 && e
->ts
.u
.cl
->length
)
832 symbol
->ts
.u
.cl
->length
= get_len_call (gfc_copy_expr (e
));
835 symbol
->attr
.allocatable
= 1;
836 symbol
->ts
.u
.cl
->length
= NULL
;
837 symbol
->ts
.deferred
= 1;
842 symbol
->attr
.flavor
= FL_VARIABLE
;
843 symbol
->attr
.referenced
= 1;
844 symbol
->attr
.dimension
= e
->rank
> 0;
845 symbol
->attr
.fe_temp
= 1;
846 gfc_commit_symbol (symbol
);
848 result
= gfc_get_expr ();
849 result
->expr_type
= EXPR_VARIABLE
;
850 result
->ts
= symbol
->ts
;
851 result
->ts
.deferred
= deferred
;
852 result
->rank
= e
->rank
;
853 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
854 result
->symtree
= symtree
;
855 result
->where
= e
->where
;
858 result
->ref
= gfc_get_ref ();
859 result
->ref
->type
= REF_ARRAY
;
860 result
->ref
->u
.ar
.type
= AR_FULL
;
861 result
->ref
->u
.ar
.where
= e
->where
;
862 result
->ref
->u
.ar
.dimen
= e
->rank
;
863 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
864 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
865 if (warn_array_temporaries
)
866 gfc_warning (OPT_Warray_temporaries
,
867 "Creating array temporary at %L", &(e
->where
));
870 /* Generate the new assignment. */
871 n
= XCNEW (gfc_code
);
873 n
->loc
= (*current_code
)->loc
;
874 n
->next
= *changed_statement
;
875 n
->expr1
= gfc_copy_expr (result
);
877 *changed_statement
= n
;
883 /* Warn about function elimination. */
886 do_warn_function_elimination (gfc_expr
*e
)
889 if (e
->expr_type
== EXPR_FUNCTION
890 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
893 gfc_warning (OPT_Wfunction_elimination
,
894 "Removing call to impure function %qs at %L", name
,
897 gfc_warning (OPT_Wfunction_elimination
,
898 "Removing call to impure function at %L",
904 /* Callback function for the code walker for doing common function
905 elimination. This builds up the list of functions in the expression
906 and goes through them to detect duplicates, which it then replaces
910 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
911 void *data ATTRIBUTE_UNUSED
)
917 /* Don't do this optimization within OMP workshare or ASSOC lists. */
919 if (in_omp_workshare
|| in_assoc_list
)
925 expr_array
.release ();
927 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
929 /* Walk through all the functions. */
931 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
933 /* Skip if the function has been replaced by a variable already. */
934 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
941 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
944 newvar
= create_var (*ei
, "fcn");
946 if (warn_function_elimination
)
947 do_warn_function_elimination (*ej
);
950 *ej
= gfc_copy_expr (newvar
);
957 /* We did all the necessary walking in this function. */
962 /* Callback function for common function elimination, called from
963 gfc_code_walker. This keeps track of the current code, in order
964 to insert statements as needed. */
967 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
970 inserted_block
= NULL
;
971 changed_statement
= NULL
;
973 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
974 and allocation on assigment are prohibited inside WHERE, and finally
975 masking an expression would lead to wrong-code when replacing
978 b = sum(foo(a) + foo(a))
989 if ((*c
)->op
== EXEC_WHERE
)
999 /* Dummy function for expression call back, for use when we
1000 really don't want to do any walking. */
1003 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
1004 void *data ATTRIBUTE_UNUSED
)
1010 /* Dummy function for code callback, for use when we really
1011 don't want to do anything. */
1013 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
1014 int *walk_subtrees ATTRIBUTE_UNUSED
,
1015 void *data ATTRIBUTE_UNUSED
)
1020 /* Code callback function for converting
1027 This is because common function elimination would otherwise place the
1028 temporary variables outside the loop. */
1031 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1032 void *data ATTRIBUTE_UNUSED
)
1035 gfc_code
*c_if1
, *c_if2
, *c_exit
;
1036 gfc_code
*loopblock
;
1037 gfc_expr
*e_not
, *e_cond
;
1039 if (co
->op
!= EXEC_DO_WHILE
)
1042 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1047 /* Generate the condition of the if statement, which is .not. the original
1049 e_not
= gfc_get_expr ();
1050 e_not
->ts
= e_cond
->ts
;
1051 e_not
->where
= e_cond
->where
;
1052 e_not
->expr_type
= EXPR_OP
;
1053 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1054 e_not
->value
.op
.op1
= e_cond
;
1056 /* Generate the EXIT statement. */
1057 c_exit
= XCNEW (gfc_code
);
1058 c_exit
->op
= EXEC_EXIT
;
1059 c_exit
->ext
.which_construct
= co
;
1060 c_exit
->loc
= co
->loc
;
1062 /* Generate the IF statement. */
1063 c_if2
= XCNEW (gfc_code
);
1064 c_if2
->op
= EXEC_IF
;
1065 c_if2
->expr1
= e_not
;
1066 c_if2
->next
= c_exit
;
1067 c_if2
->loc
= co
->loc
;
1069 /* ... plus the one to chain it to. */
1070 c_if1
= XCNEW (gfc_code
);
1071 c_if1
->op
= EXEC_IF
;
1072 c_if1
->block
= c_if2
;
1073 c_if1
->loc
= co
->loc
;
1075 /* Make the DO WHILE loop into a DO block by replacing the condition
1076 with a true constant. */
1077 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1079 /* Hang the generated if statement into the loop body. */
1081 loopblock
= co
->block
->next
;
1082 co
->block
->next
= c_if1
;
1083 c_if1
->next
= loopblock
;
1088 /* Code callback function for converting
1101 because otherwise common function elimination would place the BLOCKs
1102 into the wrong place. */
1105 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1106 void *data ATTRIBUTE_UNUSED
)
1109 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1111 if (co
->op
!= EXEC_IF
)
1114 /* This loop starts out with the first ELSE statement. */
1115 else_stmt
= co
->block
->block
;
1117 while (else_stmt
!= NULL
)
1119 gfc_code
*next_else
;
1121 /* If there is no condition, we're done. */
1122 if (else_stmt
->expr1
== NULL
)
1125 next_else
= else_stmt
->block
;
1127 /* Generate the new IF statement. */
1128 c_if2
= XCNEW (gfc_code
);
1129 c_if2
->op
= EXEC_IF
;
1130 c_if2
->expr1
= else_stmt
->expr1
;
1131 c_if2
->next
= else_stmt
->next
;
1132 c_if2
->loc
= else_stmt
->loc
;
1133 c_if2
->block
= next_else
;
1135 /* ... plus the one to chain it to. */
1136 c_if1
= XCNEW (gfc_code
);
1137 c_if1
->op
= EXEC_IF
;
1138 c_if1
->block
= c_if2
;
1139 c_if1
->loc
= else_stmt
->loc
;
1141 /* Insert the new IF after the ELSE. */
1142 else_stmt
->expr1
= NULL
;
1143 else_stmt
->next
= c_if1
;
1144 else_stmt
->block
= NULL
;
1146 else_stmt
= next_else
;
1148 /* Don't walk subtrees. */
1152 /* Callback function to var_in_expr - return true if expr1 and
1153 expr2 are identical variables. */
1155 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1158 gfc_expr
*expr1
= (gfc_expr
*) data
;
1159 gfc_expr
*expr2
= *e
;
1161 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1164 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1167 /* Return true if expr1 is found in expr2. */
1170 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1172 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1174 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1179 struct do_stack
*prev
;
1184 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1185 optimize by replacing do loops with their analog array slices. For
1188 write (*,*) (a(i), i=1,4)
1192 write (*,*) a(1:4:1) . */
1195 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1198 gfc_expr
*new_e
, *expr
, *start
;
1200 struct do_stack ds_push
;
1201 int i
, future_rank
= 0;
1202 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1205 /* Find the first transfer/do statement. */
1206 for (curr
= code
; curr
; curr
= curr
->next
)
1208 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1212 /* Ensure it is the only transfer/do statement because cases like
1214 write (*,*) (a(i), b(i), i=1,4)
1216 cannot be optimized. */
1218 if (!curr
|| curr
->next
)
1221 if (curr
->op
== EXEC_DO
)
1223 if (curr
->ext
.iterator
->var
->ref
)
1225 ds_push
.prev
= stack_top
;
1226 ds_push
.iter
= curr
->ext
.iterator
;
1227 ds_push
.code
= curr
;
1228 stack_top
= &ds_push
;
1229 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1231 if (curr
!= stack_top
->code
&& !*has_reached
)
1233 curr
->block
->next
= NULL
;
1234 gfc_free_statements (curr
);
1237 *has_reached
= true;
1243 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1247 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1250 /* Find the iterators belonging to each variable and check conditions. */
1251 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1253 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1254 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1257 start
= ref
->u
.ar
.start
[i
];
1258 gfc_simplify_expr (start
, 0);
1259 switch (start
->expr_type
)
1263 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1267 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1268 if (!stack_top
|| !stack_top
->iter
1269 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1271 /* Check for (a(i,i), i=1,3). */
1275 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1282 iters
[i
] = stack_top
->iter
;
1283 stack_top
= stack_top
->prev
;
1291 switch (start
->value
.op
.op
)
1293 case INTRINSIC_PLUS
:
1294 case INTRINSIC_TIMES
:
1295 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1296 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1298 case INTRINSIC_MINUS
:
1299 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1300 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1301 || start
->value
.op
.op1
->ref
)
1303 if (!stack_top
|| !stack_top
->iter
1304 || stack_top
->iter
->var
->symtree
1305 != start
->value
.op
.op1
->symtree
)
1307 iters
[i
] = stack_top
->iter
;
1308 stack_top
= stack_top
->prev
;
1320 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1321 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1325 gfc_expr
*var
= iters
[i
]->var
;
1326 for (int j
= i
- 1; j
< i
; j
++)
1329 && (var_in_expr (var
, iters
[j
]->start
)
1330 || var_in_expr (var
, iters
[j
]->end
)
1331 || var_in_expr (var
, iters
[j
]->step
)))
1337 /* Create new expr. */
1338 new_e
= gfc_copy_expr (curr
->expr1
);
1339 new_e
->expr_type
= EXPR_VARIABLE
;
1340 new_e
->rank
= future_rank
;
1341 if (curr
->expr1
->shape
)
1342 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1344 /* Assign new starts, ends and strides if necessary. */
1345 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1349 start
= ref
->u
.ar
.start
[i
];
1350 switch (start
->expr_type
)
1353 gfc_internal_error ("bad expression");
1356 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1357 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1358 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1359 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1360 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1361 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1364 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1365 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1366 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1367 expr
= gfc_copy_expr (start
);
1368 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1369 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1370 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1371 expr
= gfc_copy_expr (start
);
1372 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1373 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1374 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1375 switch (start
->value
.op
.op
)
1377 case INTRINSIC_MINUS
:
1378 case INTRINSIC_PLUS
:
1379 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1381 case INTRINSIC_TIMES
:
1382 expr
= gfc_copy_expr (start
);
1383 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1384 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1385 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1388 gfc_internal_error ("bad op");
1392 gfc_internal_error ("bad expression");
1395 curr
->expr1
= new_e
;
1397 /* Insert modified statement. Check whether the statement needs to be
1398 inserted at the lowest level. */
1399 if (!stack_top
->iter
)
1403 curr
->next
= prev
->next
->next
;
1408 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1409 stack_top
->code
->block
->next
= curr
;
1413 stack_top
->code
->block
->next
= curr
;
1417 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1418 tries to optimize its block. */
1421 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1422 void *data ATTRIBUTE_UNUSED
)
1424 gfc_code
**curr
, *prev
= NULL
;
1425 struct do_stack write
, first
;
1429 || ((*code
)->block
->op
!= EXEC_WRITE
1430 && (*code
)->block
->op
!= EXEC_READ
))
1438 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1440 if ((*curr
)->op
== EXEC_DO
)
1442 first
.prev
= &write
;
1443 first
.iter
= (*curr
)->ext
.iterator
;
1446 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1454 /* Optimize a namespace, including all contained namespaces.
1455 flag_frontend_optimize and flag_fronend_loop_interchange are
1456 handled separately. */
1459 optimize_namespace (gfc_namespace
*ns
)
1461 gfc_namespace
*saved_ns
= gfc_current_ns
;
1463 gfc_current_ns
= ns
;
1466 in_assoc_list
= false;
1467 in_omp_workshare
= false;
1469 if (flag_frontend_optimize
)
1471 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1472 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1473 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1474 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1475 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1476 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1482 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1487 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1491 if (flag_external_blas
)
1492 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1495 if (flag_inline_matmul_limit
!= 0)
1496 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1500 if (flag_frontend_loop_interchange
)
1501 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1504 /* BLOCKs are handled in the expression walker below. */
1505 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1507 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1508 optimize_namespace (ns
);
1510 gfc_current_ns
= saved_ns
;
1513 /* Handle dependencies for allocatable strings which potentially redefine
1514 themselves in an assignment. */
1517 realloc_strings (gfc_namespace
*ns
)
1520 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1522 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1524 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1525 realloc_strings (ns
);
1531 optimize_reduction (gfc_namespace
*ns
)
1534 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1535 callback_reduction
, NULL
);
1537 /* BLOCKs are handled in the expression walker below. */
1538 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1540 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1541 optimize_reduction (ns
);
1545 /* Replace code like
1548 a = matmul(b,c) ; a = a + d
1549 where the array function is not elemental and not allocatable
1550 and does not depend on the left-hand side.
1554 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1562 if (e
->expr_type
== EXPR_OP
)
1564 switch (e
->value
.op
.op
)
1566 /* Unary operators and exponentiation: Only look at a single
1569 case INTRINSIC_UPLUS
:
1570 case INTRINSIC_UMINUS
:
1571 case INTRINSIC_PARENTHESES
:
1572 case INTRINSIC_POWER
:
1573 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1577 case INTRINSIC_CONCAT
:
1578 /* Do not do string concatenations. */
1582 /* Binary operators. */
1583 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1586 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1592 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1593 && ! (e
->value
.function
.esym
1594 && (e
->value
.function
.esym
->attr
.elemental
1595 || e
->value
.function
.esym
->attr
.allocatable
1596 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1597 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1598 && ! (e
->value
.function
.isym
1599 && (e
->value
.function
.isym
->elemental
1600 || e
->ts
.type
!= c
->expr1
->ts
.type
1601 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1602 && ! gfc_inline_intrinsic_function_p (e
))
1608 /* Insert a new assignment statement after the current one. */
1609 n
= XCNEW (gfc_code
);
1610 n
->op
= EXEC_ASSIGN
;
1615 n
->expr1
= gfc_copy_expr (c
->expr1
);
1616 n
->expr2
= c
->expr2
;
1617 new_expr
= gfc_copy_expr (c
->expr1
);
1625 /* Nothing to optimize. */
1629 /* Remove unneeded TRIMs at the end of expressions. */
1632 remove_trim (gfc_expr
*rhs
)
1640 /* Check for a // b // trim(c). Looping is probably not
1641 necessary because the parser usually generates
1642 (// (// a b ) trim(c) ) , but better safe than sorry. */
1644 while (rhs
->expr_type
== EXPR_OP
1645 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1646 rhs
= rhs
->value
.op
.op2
;
1648 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1649 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1651 strip_function_call (rhs
);
1652 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1660 /* Optimizations for an assignment. */
1663 optimize_assignment (gfc_code
* c
)
1665 gfc_expr
*lhs
, *rhs
;
1670 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1672 /* Optimize a = trim(b) to a = b. */
1675 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1676 if (is_empty_string (rhs
))
1677 rhs
->value
.character
.length
= 0;
1680 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1681 optimize_binop_array_assignment (c
, &rhs
, false);
1685 /* Remove an unneeded function call, modifying the expression.
1686 This replaces the function call with the value of its
1687 first argument. The rest of the argument list is freed. */
1690 strip_function_call (gfc_expr
*e
)
1693 gfc_actual_arglist
*a
;
1695 a
= e
->value
.function
.actual
;
1697 /* We should have at least one argument. */
1698 gcc_assert (a
->expr
!= NULL
);
1702 /* Free the remaining arglist, if any. */
1704 gfc_free_actual_arglist (a
->next
);
1706 /* Graft the argument expression onto the original function. */
1712 /* Optimization of lexical comparison functions. */
1715 optimize_lexical_comparison (gfc_expr
*e
)
1717 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1720 switch (e
->value
.function
.isym
->id
)
1723 return optimize_comparison (e
, INTRINSIC_LE
);
1726 return optimize_comparison (e
, INTRINSIC_GE
);
1729 return optimize_comparison (e
, INTRINSIC_GT
);
1732 return optimize_comparison (e
, INTRINSIC_LT
);
1740 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1741 do CHARACTER because of possible pessimization involving character
1745 combine_array_constructor (gfc_expr
*e
)
1748 gfc_expr
*op1
, *op2
;
1751 gfc_constructor
*c
, *new_c
;
1752 gfc_constructor_base oldbase
, newbase
;
1757 /* Array constructors have rank one. */
1761 /* Don't try to combine association lists, this makes no sense
1762 and leads to an ICE. */
1766 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1767 if (forall_level
> 0)
1770 /* Inside an iterator, things can get hairy; we are likely to create
1771 an invalid temporary variable. */
1772 if (iterator_level
> 0)
1775 /* WHERE also doesn't work. */
1779 op1
= e
->value
.op
.op1
;
1780 op2
= e
->value
.op
.op2
;
1785 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1786 scalar_first
= false;
1787 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1789 scalar_first
= true;
1790 op1
= e
->value
.op
.op2
;
1791 op2
= e
->value
.op
.op1
;
1796 if (op2
->ts
.type
== BT_CHARACTER
)
1799 /* This might be an expanded constructor with very many constant values. If
1800 we perform the operation here, we might end up with a long compile time
1801 and actually longer execution time, so a length bound is in order here.
1802 If the constructor constains something which is not a constant, it did
1803 not come from an expansion, so leave it alone. */
1805 #define CONSTR_LEN_MAX 4
1807 oldbase
= op1
->value
.constructor
;
1811 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1813 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1821 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1824 #undef CONSTR_LEN_MAX
1827 e
->expr_type
= EXPR_ARRAY
;
1829 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1831 for (c
= gfc_constructor_first (oldbase
); c
;
1832 c
= gfc_constructor_next (c
))
1834 new_expr
= gfc_get_expr ();
1835 new_expr
->ts
= e
->ts
;
1836 new_expr
->expr_type
= EXPR_OP
;
1837 new_expr
->rank
= c
->expr
->rank
;
1838 new_expr
->where
= c
->expr
->where
;
1839 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1843 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1844 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1848 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1849 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1852 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1853 new_c
->iterator
= c
->iterator
;
1857 gfc_free_expr (op1
);
1858 gfc_free_expr (op2
);
1859 gfc_free_expr (scalar
);
1861 e
->value
.constructor
= newbase
;
1865 /* Recursive optimization of operators. */
1868 optimize_op (gfc_expr
*e
)
1872 gfc_intrinsic_op op
= e
->value
.op
.op
;
1876 /* Only use new-style comparisons. */
1879 case INTRINSIC_EQ_OS
:
1883 case INTRINSIC_GE_OS
:
1887 case INTRINSIC_LE_OS
:
1891 case INTRINSIC_NE_OS
:
1895 case INTRINSIC_GT_OS
:
1899 case INTRINSIC_LT_OS
:
1915 changed
= optimize_comparison (e
, op
);
1918 /* Look at array constructors. */
1919 case INTRINSIC_PLUS
:
1920 case INTRINSIC_MINUS
:
1921 case INTRINSIC_TIMES
:
1922 case INTRINSIC_DIVIDE
:
1923 return combine_array_constructor (e
) || changed
;
1933 /* Return true if a constant string contains only blanks. */
1936 is_empty_string (gfc_expr
*e
)
1940 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1943 for (i
=0; i
< e
->value
.character
.length
; i
++)
1945 if (e
->value
.character
.string
[i
] != ' ')
1953 /* Insert a call to the intrinsic len_trim. Use a different name for
1954 the symbol tree so we don't run into trouble when the user has
1955 renamed len_trim for some reason. */
1958 get_len_trim_call (gfc_expr
*str
, int kind
)
1961 gfc_actual_arglist
*actual_arglist
, *next
;
1963 fcn
= gfc_get_expr ();
1964 fcn
->expr_type
= EXPR_FUNCTION
;
1965 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1966 actual_arglist
= gfc_get_actual_arglist ();
1967 actual_arglist
->expr
= str
;
1968 next
= gfc_get_actual_arglist ();
1969 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1970 actual_arglist
->next
= next
;
1972 fcn
->value
.function
.actual
= actual_arglist
;
1973 fcn
->where
= str
->where
;
1974 fcn
->ts
.type
= BT_INTEGER
;
1975 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1977 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1978 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1979 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1980 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1981 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1982 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1983 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1984 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1990 /* Optimize expressions for equality. */
1993 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1995 gfc_expr
*op1
, *op2
;
1999 gfc_actual_arglist
*firstarg
, *secondarg
;
2001 if (e
->expr_type
== EXPR_OP
)
2005 op1
= e
->value
.op
.op1
;
2006 op2
= e
->value
.op
.op2
;
2008 else if (e
->expr_type
== EXPR_FUNCTION
)
2010 /* One of the lexical comparison functions. */
2011 firstarg
= e
->value
.function
.actual
;
2012 secondarg
= firstarg
->next
;
2013 op1
= firstarg
->expr
;
2014 op2
= secondarg
->expr
;
2019 /* Strip off unneeded TRIM calls from string comparisons. */
2021 change
= remove_trim (op1
);
2023 if (remove_trim (op2
))
2026 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2027 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2028 handles them well). However, there are also cases that need a non-scalar
2029 argument. For example the any intrinsic. See PR 45380. */
2033 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2035 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2036 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2038 bool empty_op1
, empty_op2
;
2039 empty_op1
= is_empty_string (op1
);
2040 empty_op2
= is_empty_string (op2
);
2042 if (empty_op1
|| empty_op2
)
2048 /* This can only happen when an error for comparing
2049 characters of different kinds has already been issued. */
2050 if (empty_op1
&& empty_op2
)
2053 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2054 str
= empty_op1
? op2
: op1
;
2056 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2060 gfc_free_expr (op1
);
2062 gfc_free_expr (op2
);
2066 e
->value
.op
.op1
= fcn
;
2067 e
->value
.op
.op2
= zero
;
2072 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2074 if (flag_finite_math_only
2075 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2076 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2078 eq
= gfc_dep_compare_expr (op1
, op2
);
2081 /* Replace A // B < A // C with B < C, and A // B < C // B
2083 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2084 && op1
->expr_type
== EXPR_OP
2085 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2086 && op2
->expr_type
== EXPR_OP
2087 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2089 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2090 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2091 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2092 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2094 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2096 /* Watch out for 'A ' // x vs. 'A' // x. */
2098 if (op1_left
->expr_type
== EXPR_CONSTANT
2099 && op2_left
->expr_type
== EXPR_CONSTANT
2100 && op1_left
->value
.character
.length
2101 != op2_left
->value
.character
.length
)
2109 firstarg
->expr
= op1_right
;
2110 secondarg
->expr
= op2_right
;
2114 e
->value
.op
.op1
= op1_right
;
2115 e
->value
.op
.op2
= op2_right
;
2117 optimize_comparison (e
, op
);
2121 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2127 firstarg
->expr
= op1_left
;
2128 secondarg
->expr
= op2_left
;
2132 e
->value
.op
.op1
= op1_left
;
2133 e
->value
.op
.op2
= op2_left
;
2136 optimize_comparison (e
, op
);
2143 /* eq can only be -1, 0 or 1 at this point. */
2171 gfc_internal_error ("illegal OP in optimize_comparison");
2175 /* Replace the expression by a constant expression. The typespec
2176 and where remains the way it is. */
2179 e
->expr_type
= EXPR_CONSTANT
;
2180 e
->value
.logical
= result
;
2188 /* Optimize a trim function by replacing it with an equivalent substring
2189 involving a call to len_trim. This only works for expressions where
2190 variables are trimmed. Return true if anything was modified. */
2193 optimize_trim (gfc_expr
*e
)
2198 gfc_ref
**rr
= NULL
;
2200 /* Don't do this optimization within an argument list, because
2201 otherwise aliasing issues may occur. */
2203 if (count_arglist
!= 1)
2206 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2207 || e
->value
.function
.isym
== NULL
2208 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2211 a
= e
->value
.function
.actual
->expr
;
2213 if (a
->expr_type
!= EXPR_VARIABLE
)
2216 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2218 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2221 /* Follow all references to find the correct place to put the newly
2222 created reference. FIXME: Also handle substring references and
2223 array references. Array references cause strange regressions at
2228 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2230 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2235 strip_function_call (e
);
2240 /* Create the reference. */
2242 ref
= gfc_get_ref ();
2243 ref
->type
= REF_SUBSTRING
;
2245 /* Set the start of the reference. */
2247 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2249 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2251 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2253 /* Set the end of the reference to the call to len_trim. */
2255 ref
->u
.ss
.end
= fcn
;
2256 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2261 /* Optimize minloc(b), where b is rank 1 array, into
2262 (/ minloc(b, dim=1) /), and similarly for maxloc,
2263 as the latter forms are expanded inline. */
2266 optimize_minmaxloc (gfc_expr
**e
)
2269 gfc_actual_arglist
*a
;
2273 || fn
->value
.function
.actual
== NULL
2274 || fn
->value
.function
.actual
->expr
== NULL
2275 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2278 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2279 (*e
)->shape
= fn
->shape
;
2282 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2284 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2285 strcpy (name
, fn
->value
.function
.name
);
2286 p
= strstr (name
, "loc0");
2288 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2289 if (fn
->value
.function
.actual
->next
)
2291 a
= fn
->value
.function
.actual
->next
;
2292 gcc_assert (a
->expr
== NULL
);
2296 a
= gfc_get_actual_arglist ();
2297 fn
->value
.function
.actual
->next
= a
;
2299 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2301 mpz_set_ui (a
->expr
->value
.integer
, 1);
2304 /* Callback function for code checking that we do not pass a DO variable to an
2305 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2308 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2309 void *data ATTRIBUTE_UNUSED
)
2313 gfc_formal_arglist
*f
;
2314 gfc_actual_arglist
*a
;
2321 /* If the doloop_list grew, we have to truncate it here. */
2323 if ((unsigned) doloop_level
< doloop_list
.length())
2324 doloop_list
.truncate (doloop_level
);
2331 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2336 loop
.branch_level
= if_level
+ select_level
;
2337 loop
.seen_goto
= false;
2338 doloop_list
.safe_push (loop
);
2341 /* If anything could transfer control away from a suspicious
2342 subscript, make sure to set seen_goto in the current DO loop
2347 case EXEC_ERROR_STOP
:
2353 if (co
->ext
.open
->err
)
2358 if (co
->ext
.close
->err
)
2362 case EXEC_BACKSPACE
:
2367 if (co
->ext
.filepos
->err
)
2372 if (co
->ext
.filepos
->err
)
2378 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2383 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2384 loop
.seen_goto
= true;
2389 if (co
->resolved_sym
== NULL
)
2392 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2394 /* Withot a formal arglist, there is only unknown INTENT,
2395 which we don't check for. */
2403 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2411 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2413 if (a
->expr
&& a
->expr
->symtree
2414 && a
->expr
->symtree
->n
.sym
== do_sym
)
2416 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2417 gfc_error_now ("Variable %qs at %L set to undefined "
2418 "value inside loop beginning at %L as "
2419 "INTENT(OUT) argument to subroutine %qs",
2420 do_sym
->name
, &a
->expr
->where
,
2421 &(doloop_list
[i
].c
->loc
),
2422 co
->symtree
->n
.sym
->name
);
2423 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2424 gfc_error_now ("Variable %qs at %L not definable inside "
2425 "loop beginning at %L as INTENT(INOUT) "
2426 "argument to subroutine %qs",
2427 do_sym
->name
, &a
->expr
->where
,
2428 &(doloop_list
[i
].c
->loc
),
2429 co
->symtree
->n
.sym
->name
);
2440 if (seen_goto
&& doloop_level
> 0)
2441 doloop_list
[doloop_level
-1].seen_goto
= true;
2446 /* Callback function to warn about different things within DO loops. */
2449 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2450 void *data ATTRIBUTE_UNUSED
)
2454 if (doloop_list
.length () == 0)
2457 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2460 last
= &doloop_list
.last();
2461 if (last
->seen_goto
&& !warn_do_subscript
)
2464 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2476 /* Callback function - if the expression is the variable in data->sym,
2477 replace it with a constant from data->val. */
2480 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2487 if (ex
->expr_type
!= EXPR_VARIABLE
)
2490 d
= (insert_index_t
*) data
;
2491 if (ex
->symtree
->n
.sym
!= d
->sym
)
2494 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2495 mpz_set (n
->value
.integer
, d
->val
);
2502 /* In the expression e, replace occurrences of the variable sym with
2503 val. If this results in a constant expression, return true and
2504 return the value in ret. Return false if the expression already
2505 is a constant. Caller has to clear ret in that case. */
2508 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2511 insert_index_t data
;
2514 if (e
->expr_type
== EXPR_CONSTANT
)
2517 n
= gfc_copy_expr (e
);
2519 mpz_init_set (data
.val
, val
);
2520 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2521 gfc_simplify_expr (n
, 0);
2523 if (n
->expr_type
== EXPR_CONSTANT
)
2526 mpz_init_set (ret
, n
->value
.integer
);
2531 mpz_clear (data
.val
);
2537 /* Check array subscripts for possible out-of-bounds accesses in DO
2538 loops with constant bounds. */
2541 do_subscript (gfc_expr
**e
)
2551 /* Constants are already checked. */
2552 if (v
->expr_type
== EXPR_CONSTANT
)
2555 /* Wrong warnings will be generated in an associate list. */
2559 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2561 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2564 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2567 mpz_t do_start
, do_step
, do_end
;
2568 bool have_do_start
, have_do_end
;
2569 bool error_not_proven
;
2576 /* If we are within a branch, or a goto or equivalent
2577 was seen in the DO loop before, then we cannot prove that
2578 this expression is actually evaluated. Don't do anything
2579 unless we want to see it all. */
2580 error_not_proven
= lp
->seen_goto
2581 || lp
->branch_level
< if_level
+ select_level
;
2583 if (error_not_proven
&& !warn_do_subscript
)
2586 if (error_not_proven
)
2587 warn
= OPT_Wdo_subscript
;
2591 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2592 if (do_sym
->ts
.type
!= BT_INTEGER
)
2595 /* If we do not know about the stepsize, the loop may be zero trip.
2596 Do not warn in this case. */
2598 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2599 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2603 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2605 have_do_start
= true;
2606 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2609 have_do_start
= false;
2612 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2615 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2618 have_do_end
= false;
2620 if (!have_do_start
&& !have_do_end
)
2623 /* May have to correct the end value if the step does not equal
2625 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2631 mpz_sub (diff
, do_end
, do_start
);
2632 mpz_tdiv_r (rem
, diff
, do_step
);
2633 mpz_sub (do_end
, do_end
, rem
);
2638 for (i
= 0; i
< ar
->dimen
; i
++)
2641 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2642 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2644 if (ar
->as
->lower
[i
]
2645 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2646 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2647 gfc_warning (warn
, "Array reference at %L out of bounds "
2648 "(%ld < %ld) in loop beginning at %L",
2649 &ar
->start
[i
]->where
, mpz_get_si (val
),
2650 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2651 &doloop_list
[j
].c
->loc
);
2653 if (ar
->as
->upper
[i
]
2654 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2655 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2656 gfc_warning (warn
, "Array reference at %L out of bounds "
2657 "(%ld > %ld) in loop beginning at %L",
2658 &ar
->start
[i
]->where
, mpz_get_si (val
),
2659 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2660 &doloop_list
[j
].c
->loc
);
2665 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2666 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2668 if (ar
->as
->lower
[i
]
2669 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2670 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2671 gfc_warning (warn
, "Array reference at %L out of bounds "
2672 "(%ld < %ld) in loop beginning at %L",
2673 &ar
->start
[i
]->where
, mpz_get_si (val
),
2674 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2675 &doloop_list
[j
].c
->loc
);
2677 if (ar
->as
->upper
[i
]
2678 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2679 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2680 gfc_warning (warn
, "Array reference at %L out of bounds "
2681 "(%ld > %ld) in loop beginning at %L",
2682 &ar
->start
[i
]->where
, mpz_get_si (val
),
2683 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2684 &doloop_list
[j
].c
->loc
);
2694 /* Function for functions checking that we do not pass a DO variable
2695 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2698 do_intent (gfc_expr
**e
)
2700 gfc_formal_arglist
*f
;
2701 gfc_actual_arglist
*a
;
2708 if (expr
->expr_type
!= EXPR_FUNCTION
)
2711 /* Intrinsic functions don't modify their arguments. */
2713 if (expr
->value
.function
.isym
)
2716 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2718 /* Without a formal arglist, there is only unknown INTENT,
2719 which we don't check for. */
2723 a
= expr
->value
.function
.actual
;
2727 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2734 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2736 if (a
->expr
&& a
->expr
->symtree
2737 && a
->expr
->symtree
->n
.sym
== do_sym
)
2739 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2740 gfc_error_now ("Variable %qs at %L set to undefined value "
2741 "inside loop beginning at %L as INTENT(OUT) "
2742 "argument to function %qs", do_sym
->name
,
2743 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2744 expr
->symtree
->n
.sym
->name
);
2745 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2746 gfc_error_now ("Variable %qs at %L not definable inside loop"
2747 " beginning at %L as INTENT(INOUT) argument to"
2748 " function %qs", do_sym
->name
,
2749 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2750 expr
->symtree
->n
.sym
->name
);
2761 doloop_warn (gfc_namespace
*ns
)
2763 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2766 /* This selction deals with inlining calls to MATMUL. */
2768 /* Replace calls to matmul outside of straight assignments with a temporary
2769 variable so that later inlining will work. */
2772 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2776 bool *found
= (bool *) data
;
2780 if (e
->expr_type
!= EXPR_FUNCTION
2781 || e
->value
.function
.isym
== NULL
2782 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2785 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2786 || in_where
|| in_assoc_list
)
2789 /* Check if this is already in the form c = matmul(a,b). */
2791 if ((*current_code
)->expr2
== e
)
2794 n
= create_var (e
, "matmul");
2796 /* If create_var is unable to create a variable (for example if
2797 -fno-realloc-lhs is in force with a variable that does not have bounds
2798 known at compile-time), just return. */
2808 /* Set current_code and associated variables so that matmul_to_var_expr can
2812 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2813 void *data ATTRIBUTE_UNUSED
)
2815 if (current_code
!= c
)
2818 inserted_block
= NULL
;
2819 changed_statement
= NULL
;
2826 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2827 for a and b if there is a dependency between the arguments and the
2828 result variable or if a or b are the result of calculations that cannot
2829 be handled by the inliner. */
2832 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2833 void *data ATTRIBUTE_UNUSED
)
2835 gfc_expr
*expr1
, *expr2
;
2837 gfc_actual_arglist
*a
, *b
;
2839 gfc_expr
*matrix_a
, *matrix_b
;
2840 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2844 if (co
->op
!= EXEC_ASSIGN
)
2847 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2851 /* This has some duplication with inline_matmul_assign. This
2852 is because the creation of temporary variables could still fail,
2853 and inline_matmul_assign still needs to be able to handle these
2858 if (expr2
->expr_type
!= EXPR_FUNCTION
2859 || expr2
->value
.function
.isym
== NULL
2860 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2864 a
= expr2
->value
.function
.actual
;
2865 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2866 if (matrix_a
!= NULL
)
2868 if (matrix_a
->expr_type
== EXPR_VARIABLE
2869 && (gfc_check_dependency (matrix_a
, expr1
, true)
2870 || gfc_has_dimen_vector_ref (matrix_a
)))
2878 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2879 if (matrix_b
!= NULL
)
2881 if (matrix_b
->expr_type
== EXPR_VARIABLE
2882 && (gfc_check_dependency (matrix_b
, expr1
, true)
2883 || gfc_has_dimen_vector_ref (matrix_b
)))
2889 if (!a_tmp
&& !b_tmp
)
2893 inserted_block
= NULL
;
2894 changed_statement
= NULL
;
2898 at
= create_var (a
->expr
,"mma");
2905 bt
= create_var (b
->expr
,"mmb");
2912 /* Auxiliary function to build and simplify an array inquiry function.
2913 dim is zero-based. */
2916 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
2919 gfc_expr
*dim_arg
, *kind
;
2925 case GFC_ISYM_LBOUND
:
2926 name
= "_gfortran_lbound";
2929 case GFC_ISYM_UBOUND
:
2930 name
= "_gfortran_ubound";
2934 name
= "_gfortran_size";
2941 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2943 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2946 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2947 gfc_index_integer_kind
);
2949 ec
= gfc_copy_expr (e
);
2951 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2953 ec
->no_bounds_check
= 1;
2954 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2956 gfc_simplify_expr (fcn
, 0);
2957 fcn
->no_bounds_check
= 1;
2961 /* Builds a logical expression. */
2964 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2969 ts
.type
= BT_LOGICAL
;
2970 ts
.kind
= gfc_default_logical_kind
;
2971 res
= gfc_get_expr ();
2972 res
->where
= e1
->where
;
2973 res
->expr_type
= EXPR_OP
;
2974 res
->value
.op
.op
= op
;
2975 res
->value
.op
.op1
= e1
;
2976 res
->value
.op
.op2
= e2
;
2983 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2984 compatible typespecs. */
2987 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2991 res
= gfc_get_expr ();
2993 res
->where
= e1
->where
;
2994 res
->expr_type
= EXPR_OP
;
2995 res
->value
.op
.op
= op
;
2996 res
->value
.op
.op1
= e1
;
2997 res
->value
.op
.op2
= e2
;
2998 gfc_simplify_expr (res
, 0);
3002 /* Generate the IF statement for a runtime check if we want to do inlining or
3003 not - putting in the code for both branches and putting it into the syntax
3004 tree is the caller's responsibility. For fixed array sizes, this should be
3005 removed by DCE. Only called for rank-two matrices A and B. */
3008 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3010 gfc_expr
*inline_limit
;
3011 gfc_code
*if_1
, *if_2
, *else_2
;
3012 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3016 /* Calculation is done in real to avoid integer overflow. */
3018 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3020 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3021 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3024 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3025 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3026 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3030 ts
.kind
= gfc_default_real_kind
;
3031 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3032 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3033 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3035 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3036 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3038 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3039 gfc_simplify_expr (cond
, 0);
3041 else_2
= XCNEW (gfc_code
);
3042 else_2
->op
= EXEC_IF
;
3043 else_2
->loc
= a
->where
;
3045 if_2
= XCNEW (gfc_code
);
3048 if_2
->loc
= a
->where
;
3049 if_2
->block
= else_2
;
3051 if_1
= XCNEW (gfc_code
);
3054 if_1
->loc
= a
->where
;
3060 /* Insert code to issue a runtime error if the expressions are not equal. */
3063 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3066 gfc_code
*if_1
, *if_2
;
3068 gfc_actual_arglist
*a1
, *a2
, *a3
;
3070 gcc_assert (e1
->where
.lb
);
3071 /* Build the call to runtime_error. */
3072 c
= XCNEW (gfc_code
);
3076 /* Get a null-terminated message string. */
3078 a1
= gfc_get_actual_arglist ();
3079 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3080 msg
, strlen(msg
)+1);
3083 /* Pass the value of the first expression. */
3084 a2
= gfc_get_actual_arglist ();
3085 a2
->expr
= gfc_copy_expr (e1
);
3088 /* Pass the value of the second expression. */
3089 a3
= gfc_get_actual_arglist ();
3090 a3
->expr
= gfc_copy_expr (e2
);
3093 gfc_check_fe_runtime_error (c
->ext
.actual
);
3094 gfc_resolve_fe_runtime_error (c
);
3096 if_2
= XCNEW (gfc_code
);
3098 if_2
->loc
= e1
->where
;
3101 if_1
= XCNEW (gfc_code
);
3104 if_1
->loc
= e1
->where
;
3106 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3107 gfc_simplify_expr (cond
, 0);
3113 /* Handle matrix reallocation. Caller is responsible to insert into
3116 For the two-dimensional case, build
3118 if (allocated(c)) then
3119 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3121 allocate (c(size(a,1), size(b,2)))
3124 allocate (c(size(a,1),size(b,2)))
3127 and for the other cases correspondingly.
3131 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3132 enum matrix_case m_case
)
3135 gfc_expr
*allocated
, *alloc_expr
;
3136 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3137 gfc_code
*else_alloc
;
3138 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3140 gfc_expr
*cond
, *ne1
, *ne2
;
3142 if (warn_realloc_lhs
)
3143 gfc_warning (OPT_Wrealloc_lhs
,
3144 "Code for reallocating the allocatable array at %L will "
3145 "be added", &c
->where
);
3147 alloc_expr
= gfc_copy_expr (c
);
3149 ar
= gfc_find_array_ref (alloc_expr
);
3150 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3152 /* c comes in as a full ref. Change it into a copy and make it into an
3153 element ref so it has the right form for for ALLOCATE. In the same
3154 switch statement, also generate the size comparison for the secod IF
3157 ar
->type
= AR_ELEMENT
;
3162 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3163 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3164 ne1
= build_logical_expr (INTRINSIC_NE
,
3165 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3166 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3167 ne2
= build_logical_expr (INTRINSIC_NE
,
3168 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3169 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3170 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3174 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3175 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3177 ne1
= build_logical_expr (INTRINSIC_NE
,
3178 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3179 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3180 ne2
= build_logical_expr (INTRINSIC_NE
,
3181 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3182 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3183 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3188 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3189 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3191 ne1
= build_logical_expr (INTRINSIC_NE
,
3192 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3193 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3194 ne2
= build_logical_expr (INTRINSIC_NE
,
3195 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3196 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3197 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3201 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3202 cond
= build_logical_expr (INTRINSIC_NE
,
3203 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3204 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3208 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3209 cond
= build_logical_expr (INTRINSIC_NE
,
3210 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3211 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3215 /* This can only happen for BLAS, we do not handle that case in
3217 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3218 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3220 ne1
= build_logical_expr (INTRINSIC_NE
,
3221 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3222 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3223 ne2
= build_logical_expr (INTRINSIC_NE
,
3224 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3225 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3227 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3235 gfc_simplify_expr (cond
, 0);
3237 /* We need two identical allocate statements in two
3238 branches of the IF statement. */
3240 allocate1
= XCNEW (gfc_code
);
3241 allocate1
->op
= EXEC_ALLOCATE
;
3242 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3243 allocate1
->loc
= c
->where
;
3244 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3246 allocate_else
= XCNEW (gfc_code
);
3247 allocate_else
->op
= EXEC_ALLOCATE
;
3248 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3249 allocate_else
->loc
= c
->where
;
3250 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3252 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3253 "_gfortran_allocated", c
->where
,
3254 1, gfc_copy_expr (c
));
3256 deallocate
= XCNEW (gfc_code
);
3257 deallocate
->op
= EXEC_DEALLOCATE
;
3258 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3259 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3260 deallocate
->next
= allocate1
;
3261 deallocate
->loc
= c
->where
;
3263 if_size_2
= XCNEW (gfc_code
);
3264 if_size_2
->op
= EXEC_IF
;
3265 if_size_2
->expr1
= cond
;
3266 if_size_2
->loc
= c
->where
;
3267 if_size_2
->next
= deallocate
;
3269 if_size_1
= XCNEW (gfc_code
);
3270 if_size_1
->op
= EXEC_IF
;
3271 if_size_1
->block
= if_size_2
;
3272 if_size_1
->loc
= c
->where
;
3274 else_alloc
= XCNEW (gfc_code
);
3275 else_alloc
->op
= EXEC_IF
;
3276 else_alloc
->loc
= c
->where
;
3277 else_alloc
->next
= allocate_else
;
3279 if_alloc_2
= XCNEW (gfc_code
);
3280 if_alloc_2
->op
= EXEC_IF
;
3281 if_alloc_2
->expr1
= allocated
;
3282 if_alloc_2
->loc
= c
->where
;
3283 if_alloc_2
->next
= if_size_1
;
3284 if_alloc_2
->block
= else_alloc
;
3286 if_alloc_1
= XCNEW (gfc_code
);
3287 if_alloc_1
->op
= EXEC_IF
;
3288 if_alloc_1
->block
= if_alloc_2
;
3289 if_alloc_1
->loc
= c
->where
;
3294 /* Callback function for has_function_or_op. */
3297 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3298 void *data ATTRIBUTE_UNUSED
)
3303 return (*e
)->expr_type
== EXPR_FUNCTION
3304 || (*e
)->expr_type
== EXPR_OP
;
3307 /* Returns true if the expression contains a function. */
3310 has_function_or_op (gfc_expr
**e
)
3315 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3318 /* Freeze (assign to a temporary variable) a single expression. */
3321 freeze_expr (gfc_expr
**ep
)
3324 if (has_function_or_op (ep
))
3326 ne
= create_var (*ep
, "freeze");
3331 /* Go through an expression's references and assign them to temporary
3332 variables if they contain functions. This is usually done prior to
3333 front-end scalarization to avoid multiple invocations of functions. */
3336 freeze_references (gfc_expr
*e
)
3342 for (r
=e
->ref
; r
; r
=r
->next
)
3344 if (r
->type
== REF_SUBSTRING
)
3346 if (r
->u
.ss
.start
!= NULL
)
3347 freeze_expr (&r
->u
.ss
.start
);
3349 if (r
->u
.ss
.end
!= NULL
)
3350 freeze_expr (&r
->u
.ss
.end
);
3352 else if (r
->type
== REF_ARRAY
)
3361 for (i
=0; i
<ar
->dimen
; i
++)
3363 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3365 freeze_expr (&ar
->start
[i
]);
3366 freeze_expr (&ar
->end
[i
]);
3367 freeze_expr (&ar
->stride
[i
]);
3369 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3371 freeze_expr (&ar
->start
[i
]);
3377 for (i
=0; i
<ar
->dimen
; i
++)
3378 freeze_expr (&ar
->start
[i
]);
3388 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3391 convert_to_index_kind (gfc_expr
*e
)
3395 gcc_assert (e
!= NULL
);
3397 res
= gfc_copy_expr (e
);
3399 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3401 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3405 ts
.type
= BT_INTEGER
;
3406 ts
.kind
= gfc_index_integer_kind
;
3408 gfc_convert_type_warn (e
, &ts
, 2, 0);
3414 /* Function to create a DO loop including creation of the
3415 iteration variable. gfc_expr are copied.*/
3418 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3419 gfc_namespace
*ns
, char *vname
)
3422 char name
[GFC_MAX_SYMBOL_LEN
+1];
3423 gfc_symtree
*symtree
;
3428 /* Create an expression for the iteration variable. */
3430 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3432 sprintf (name
, "__var_%d_do", var_num
++);
3435 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3438 /* Create the loop variable. */
3440 symbol
= symtree
->n
.sym
;
3441 symbol
->ts
.type
= BT_INTEGER
;
3442 symbol
->ts
.kind
= gfc_index_integer_kind
;
3443 symbol
->attr
.flavor
= FL_VARIABLE
;
3444 symbol
->attr
.referenced
= 1;
3445 symbol
->attr
.dimension
= 0;
3446 symbol
->attr
.fe_temp
= 1;
3447 gfc_commit_symbol (symbol
);
3449 i
= gfc_get_expr ();
3450 i
->expr_type
= EXPR_VARIABLE
;
3454 i
->symtree
= symtree
;
3456 /* ... and the nested DO statements. */
3457 n
= XCNEW (gfc_code
);
3460 n
->ext
.iterator
= gfc_get_iterator ();
3461 n
->ext
.iterator
->var
= i
;
3462 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3463 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3465 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3467 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3470 n2
= XCNEW (gfc_code
);
3478 /* Get the upper bound of the DO loops for matmul along a dimension. This
3482 get_size_m1 (gfc_expr
*e
, int dimen
)
3487 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3489 res
= gfc_get_constant_expr (BT_INTEGER
,
3490 gfc_index_integer_kind
, &e
->where
);
3491 mpz_sub_ui (res
->value
.integer
, size
, 1);
3496 res
= get_operand (INTRINSIC_MINUS
,
3497 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3498 gfc_get_int_expr (gfc_index_integer_kind
,
3500 gfc_simplify_expr (res
, 0);
3506 /* Function to return a scalarized expression. It is assumed that indices are
3507 zero based to make generation of DO loops easier. A zero as index will
3508 access the first element along a dimension. Single element references will
3509 be skipped. A NULL as an expression will be replaced by a full reference.
3510 This assumes that the index loops have gfc_index_integer_kind, and that all
3511 references have been frozen. */
3514 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3523 e
= gfc_copy_expr(e_in
);
3527 ar
= gfc_find_array_ref (e
);
3529 /* We scalarize count_index variables, reducing the rank by count_index. */
3531 e
->rank
= rank
- count_index
;
3533 was_fullref
= ar
->type
== AR_FULL
;
3536 ar
->type
= AR_ELEMENT
;
3538 ar
->type
= AR_SECTION
;
3540 /* Loop over the indices. For each index, create the expression
3541 index * stride + lbound(e, dim). */
3544 for (i
=0; i
< ar
->dimen
; i
++)
3546 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3548 if (index
[i_index
] != NULL
)
3550 gfc_expr
*lbound
, *nindex
;
3553 loopvar
= gfc_copy_expr (index
[i_index
]);
3559 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3560 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3564 ts
.type
= BT_INTEGER
;
3565 ts
.kind
= gfc_index_integer_kind
;
3566 gfc_convert_type (tmp
, &ts
, 2);
3568 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3573 /* Calculate the lower bound of the expression. */
3576 lbound
= gfc_copy_expr (ar
->start
[i
]);
3577 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3581 ts
.type
= BT_INTEGER
;
3582 ts
.kind
= gfc_index_integer_kind
;
3583 gfc_convert_type (lbound
, &ts
, 2);
3592 lbound_e
= gfc_copy_expr (e_in
);
3594 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3595 if (ref
->type
== REF_ARRAY
3596 && (ref
->u
.ar
.type
== AR_FULL
3597 || ref
->u
.ar
.type
== AR_SECTION
))
3602 gfc_free_ref_list (ref
->next
);
3608 /* Look at full individual sections, like a(:). The first index
3609 is the lbound of a full ref. */
3616 /* For assumed size, we need to keep around the final
3617 reference in order not to get an error on resolution
3618 below, and we cannot use AR_FULL. */
3620 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3622 ar
->type
= AR_SECTION
;
3631 for (j
= 0; j
< to
; j
++)
3633 gfc_free_expr (ar
->start
[j
]);
3634 ar
->start
[j
] = NULL
;
3635 gfc_free_expr (ar
->end
[j
]);
3637 gfc_free_expr (ar
->stride
[j
]);
3638 ar
->stride
[j
] = NULL
;
3641 /* We have to get rid of the shape, if there is one. Do
3642 so by freeing it and calling gfc_resolve to rebuild
3643 it, if necessary. */
3645 if (lbound_e
->shape
)
3646 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3648 lbound_e
->rank
= ar
->dimen
;
3649 gfc_resolve_expr (lbound_e
);
3651 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3653 gfc_free_expr (lbound_e
);
3656 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3658 gfc_free_expr (ar
->start
[i
]);
3659 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3661 gfc_free_expr (ar
->end
[i
]);
3663 gfc_free_expr (ar
->stride
[i
]);
3664 ar
->stride
[i
] = NULL
;
3665 gfc_simplify_expr (ar
->start
[i
], 0);
3667 else if (was_fullref
)
3669 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3675 /* Bounds checking will be done before the loops if -fcheck=bounds
3677 e
->no_bounds_check
= 1;
3681 /* Helper function to check for a dimen vector as subscript. */
3684 gfc_has_dimen_vector_ref (gfc_expr
*e
)
3689 ar
= gfc_find_array_ref (e
);
3691 if (ar
->type
== AR_FULL
)
3694 for (i
=0; i
<ar
->dimen
; i
++)
3695 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3701 /* If handed an expression of the form
3705 check if A can be handled by matmul and return if there is an uneven number
3706 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3707 otherwise. The caller has to check for the correct rank. */
3710 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3717 if (e
->expr_type
== EXPR_VARIABLE
)
3719 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3722 else if (e
->expr_type
== EXPR_FUNCTION
)
3724 if (e
->value
.function
.isym
== NULL
)
3727 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3729 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3730 *transpose
= !*transpose
;
3736 e
= e
->value
.function
.actual
->expr
;
3743 /* Macros for unified error messages. */
3745 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
3746 "dimension 1: is %ld, should be %ld")
3748 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
3751 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
3755 /* Inline assignments of the form c = matmul(a,b).
3756 Handle only the cases currently where b and c are rank-two arrays.
3758 This basically translates the code to
3764 do k=0, size(a, 2)-1
3765 do i=0, size(a, 1)-1
3766 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3767 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3768 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3769 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3778 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3779 void *data ATTRIBUTE_UNUSED
)
3782 gfc_expr
*expr1
, *expr2
;
3783 gfc_expr
*matrix_a
, *matrix_b
;
3784 gfc_actual_arglist
*a
, *b
;
3785 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3787 gfc_expr
*u1
, *u2
, *u3
;
3789 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3791 gfc_expr
*var_1
, *var_2
, *var_3
;
3794 gfc_intrinsic_op op_times
, op_plus
;
3795 enum matrix_case m_case
;
3797 gfc_code
*if_limit
= NULL
;
3798 gfc_code
**next_code_point
;
3799 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3802 if (co
->op
!= EXEC_ASSIGN
)
3805 if (in_where
|| in_assoc_list
)
3808 /* The BLOCKS generated for the temporary variables and FORALL don't
3810 if (forall_level
> 0)
3813 /* For now don't do anything in OpenMP workshare, it confuses
3814 its translation, which expects only the allowed statements in there.
3815 We should figure out how to parallelize this eventually. */
3816 if (in_omp_workshare
)
3821 if (expr2
->expr_type
!= EXPR_FUNCTION
3822 || expr2
->value
.function
.isym
== NULL
3823 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3827 inserted_block
= NULL
;
3828 changed_statement
= NULL
;
3830 a
= expr2
->value
.function
.actual
;
3831 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3832 if (matrix_a
== NULL
)
3836 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3837 if (matrix_b
== NULL
)
3840 if (gfc_has_dimen_vector_ref (expr1
) || gfc_has_dimen_vector_ref (matrix_a
)
3841 || gfc_has_dimen_vector_ref (matrix_b
))
3844 /* We do not handle data dependencies yet. */
3845 if (gfc_check_dependency (expr1
, matrix_a
, true)
3846 || gfc_check_dependency (expr1
, matrix_b
, true))
3850 if (matrix_a
->rank
== 2)
3854 if (matrix_b
->rank
== 2 && !transpose_b
)
3859 if (matrix_b
->rank
== 1)
3861 else /* matrix_b->rank == 2 */
3870 else /* matrix_a->rank == 1 */
3872 if (matrix_b
->rank
== 2)
3882 ns
= insert_block ();
3884 /* Assign the type of the zero expression for initializing the resulting
3885 array, and the expression (+ and * for real, integer and complex;
3886 .and. and .or for logical. */
3888 switch(expr1
->ts
.type
)
3891 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3892 op_times
= INTRINSIC_TIMES
;
3893 op_plus
= INTRINSIC_PLUS
;
3897 op_times
= INTRINSIC_AND
;
3898 op_plus
= INTRINSIC_OR
;
3899 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3903 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3905 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3906 op_times
= INTRINSIC_TIMES
;
3907 op_plus
= INTRINSIC_PLUS
;
3911 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3913 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3914 op_times
= INTRINSIC_TIMES
;
3915 op_plus
= INTRINSIC_PLUS
;
3923 current_code
= &ns
->code
;
3925 /* Freeze the references, keeping track of how many temporary variables were
3928 freeze_references (matrix_a
);
3929 freeze_references (matrix_b
);
3930 freeze_references (expr1
);
3933 next_code_point
= current_code
;
3936 next_code_point
= &ns
->code
;
3937 for (i
=0; i
<n_vars
; i
++)
3938 next_code_point
= &(*next_code_point
)->next
;
3941 /* Take care of the inline flag. If the limit check evaluates to a
3942 constant, dead code elimination will eliminate the unneeded branch. */
3944 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
3945 && matrix_b
->rank
== 2)
3947 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
3948 flag_inline_matmul_limit
);
3950 /* Insert the original statement into the else branch. */
3951 if_limit
->block
->block
->next
= co
;
3954 /* ... and the new ones go into the original one. */
3955 *next_code_point
= if_limit
;
3956 next_code_point
= &if_limit
->block
->next
;
3959 zero_e
->no_bounds_check
= 1;
3961 assign_zero
= XCNEW (gfc_code
);
3962 assign_zero
->op
= EXEC_ASSIGN
;
3963 assign_zero
->loc
= co
->loc
;
3964 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3965 assign_zero
->expr1
->no_bounds_check
= 1;
3966 assign_zero
->expr2
= zero_e
;
3968 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
3970 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3973 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3979 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3980 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3981 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
3982 *next_code_point
= test
;
3983 next_code_point
= &test
->next
;
3987 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3988 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3989 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
3990 *next_code_point
= test
;
3991 next_code_point
= &test
->next
;
3997 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3998 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3999 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4000 *next_code_point
= test
;
4001 next_code_point
= &test
->next
;
4005 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4006 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4007 test
= runtime_error_ne (c1
, b2
, C_ERROR_1
);
4008 *next_code_point
= test
;
4009 next_code_point
= &test
->next
;
4015 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4016 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4017 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4018 *next_code_point
= test
;
4019 next_code_point
= &test
->next
;
4023 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4024 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4025 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4026 *next_code_point
= test
;
4027 next_code_point
= &test
->next
;
4029 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4030 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4031 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4032 *next_code_point
= test
;
4033 next_code_point
= &test
->next
;
4039 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4040 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4041 /* matrix_b is transposed, hence dimension 1 for the error message. */
4042 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4043 *next_code_point
= test
;
4044 next_code_point
= &test
->next
;
4048 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4049 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4050 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4051 *next_code_point
= test
;
4052 next_code_point
= &test
->next
;
4054 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4055 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4056 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4057 *next_code_point
= test
;
4058 next_code_point
= &test
->next
;
4064 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4065 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4066 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4067 *next_code_point
= test
;
4068 next_code_point
= &test
->next
;
4072 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4073 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4074 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4075 *next_code_point
= test
;
4076 next_code_point
= &test
->next
;
4078 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4079 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4080 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4081 *next_code_point
= test
;
4082 next_code_point
= &test
->next
;
4091 /* Handle the reallocation, if needed. */
4095 gfc_code
*lhs_alloc
;
4097 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4099 *next_code_point
= lhs_alloc
;
4100 next_code_point
= &lhs_alloc
->next
;
4104 *next_code_point
= assign_zero
;
4106 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4108 assign_matmul
= XCNEW (gfc_code
);
4109 assign_matmul
->op
= EXEC_ASSIGN
;
4110 assign_matmul
->loc
= co
->loc
;
4112 /* Get the bounds for the loops, create them and create the scalarized
4119 u1
= get_size_m1 (matrix_b
, 2);
4120 u2
= get_size_m1 (matrix_a
, 2);
4121 u3
= get_size_m1 (matrix_a
, 1);
4123 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4124 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4125 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4127 do_1
->block
->next
= do_2
;
4128 do_2
->block
->next
= do_3
;
4129 do_3
->block
->next
= assign_matmul
;
4131 var_1
= do_1
->ext
.iterator
->var
;
4132 var_2
= do_2
->ext
.iterator
->var
;
4133 var_3
= do_3
->ext
.iterator
->var
;
4137 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4141 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4145 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4151 u1
= get_size_m1 (matrix_b
, 1);
4152 u2
= get_size_m1 (matrix_a
, 2);
4153 u3
= get_size_m1 (matrix_a
, 1);
4155 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4156 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4157 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4159 do_1
->block
->next
= do_2
;
4160 do_2
->block
->next
= do_3
;
4161 do_3
->block
->next
= assign_matmul
;
4163 var_1
= do_1
->ext
.iterator
->var
;
4164 var_2
= do_2
->ext
.iterator
->var
;
4165 var_3
= do_3
->ext
.iterator
->var
;
4169 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4173 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4177 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4183 u1
= get_size_m1 (matrix_a
, 2);
4184 u2
= get_size_m1 (matrix_b
, 2);
4185 u3
= get_size_m1 (matrix_a
, 1);
4187 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4188 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4189 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4191 do_1
->block
->next
= do_2
;
4192 do_2
->block
->next
= do_3
;
4193 do_3
->block
->next
= assign_matmul
;
4195 var_1
= do_1
->ext
.iterator
->var
;
4196 var_2
= do_2
->ext
.iterator
->var
;
4197 var_3
= do_3
->ext
.iterator
->var
;
4201 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4205 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4209 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4214 u1
= get_size_m1 (matrix_b
, 1);
4215 u2
= get_size_m1 (matrix_a
, 1);
4217 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4218 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4220 do_1
->block
->next
= do_2
;
4221 do_2
->block
->next
= assign_matmul
;
4223 var_1
= do_1
->ext
.iterator
->var
;
4224 var_2
= do_2
->ext
.iterator
->var
;
4227 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4231 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4234 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4239 u1
= get_size_m1 (matrix_b
, 2);
4240 u2
= get_size_m1 (matrix_a
, 1);
4242 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4243 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4245 do_1
->block
->next
= do_2
;
4246 do_2
->block
->next
= assign_matmul
;
4248 var_1
= do_1
->ext
.iterator
->var
;
4249 var_2
= do_2
->ext
.iterator
->var
;
4252 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4255 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4259 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4267 /* Build the conjg call around the variables. Set the typespec manually
4268 because gfc_build_intrinsic_call sometimes gets this wrong. */
4273 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4274 matrix_a
->where
, 1, ascalar
);
4282 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4283 matrix_b
->where
, 1, bscalar
);
4286 /* First loop comes after the zero assignment. */
4287 assign_zero
->next
= do_1
;
4289 /* Build the assignment expression in the loop. */
4290 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4292 mult
= get_operand (op_times
, ascalar
, bscalar
);
4293 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4295 /* If we don't want to keep the original statement around in
4296 the else branch, we can free it. */
4298 if (if_limit
== NULL
)
4299 gfc_free_statements(co
);
4303 gfc_free_expr (zero
);
4308 /* Change matmul function calls in the form of
4312 to the corresponding call to a BLAS routine, if applicable. */
4315 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4316 void *data ATTRIBUTE_UNUSED
)
4318 gfc_code
*co
, *co_next
;
4319 gfc_expr
*expr1
, *expr2
;
4320 gfc_expr
*matrix_a
, *matrix_b
;
4321 gfc_code
*if_limit
= NULL
;
4322 gfc_actual_arglist
*a
, *b
;
4323 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4325 const char *blas_name
;
4326 const char *transa
, *transb
;
4327 gfc_expr
*c1
, *c2
, *b1
;
4328 gfc_actual_arglist
*actual
, *next
;
4331 enum matrix_case m_case
;
4333 gfc_code
**next_code_point
;
4335 /* Many of the tests for inline matmul also apply here. */
4339 if (co
->op
!= EXEC_ASSIGN
)
4342 if (in_where
|| in_assoc_list
)
4345 /* The BLOCKS generated for the temporary variables and FORALL don't
4347 if (forall_level
> 0)
4350 /* For now don't do anything in OpenMP workshare, it confuses
4351 its translation, which expects only the allowed statements in there. */
4353 if (in_omp_workshare
)
4358 if (expr2
->expr_type
!= EXPR_FUNCTION
4359 || expr2
->value
.function
.isym
== NULL
4360 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4363 type
= expr2
->ts
.type
;
4364 kind
= expr2
->ts
.kind
;
4366 /* Guard against recursion. */
4368 if (expr2
->external_blas
)
4371 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4374 if (type
== BT_REAL
)
4377 blas_name
= "sgemm";
4379 blas_name
= "dgemm";
4383 else if (type
== BT_COMPLEX
)
4386 blas_name
= "cgemm";
4388 blas_name
= "zgemm";
4395 a
= expr2
->value
.function
.actual
;
4396 if (a
->expr
->rank
!= 2)
4400 if (b
->expr
->rank
!= 2)
4403 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4404 if (matrix_a
== NULL
)
4417 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4418 if (matrix_b
== NULL
)
4447 inserted_block
= NULL
;
4448 changed_statement
= NULL
;
4450 expr2
->external_blas
= 1;
4452 /* We do not handle data dependencies yet. */
4453 if (gfc_check_dependency (expr1
, matrix_a
, true)
4454 || gfc_check_dependency (expr1
, matrix_b
, true))
4457 /* Generate the if statement and hang it into the tree. */
4458 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4460 (*current_code
) = if_limit
;
4462 if_limit
->block
->next
= co
;
4464 call
= XCNEW (gfc_code
);
4465 call
->loc
= co
->loc
;
4467 /* Bounds checking - a bit simpler than for inlining since we only
4468 have to take care of two-dimensional arrays here. */
4470 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4471 next_code_point
= &(if_limit
->block
->block
->next
);
4473 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4476 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4477 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4481 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4482 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4483 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4484 *next_code_point
= test
;
4485 next_code_point
= &test
->next
;
4489 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4490 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4491 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4492 *next_code_point
= test
;
4493 next_code_point
= &test
->next
;
4495 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4496 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4497 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4498 *next_code_point
= test
;
4499 next_code_point
= &test
->next
;
4505 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4506 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4507 /* matrix_b is transposed, hence dimension 1 for the error message. */
4508 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4509 *next_code_point
= test
;
4510 next_code_point
= &test
->next
;
4514 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4515 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4516 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4517 *next_code_point
= test
;
4518 next_code_point
= &test
->next
;
4520 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4521 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4522 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4523 *next_code_point
= test
;
4524 next_code_point
= &test
->next
;
4530 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4531 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4532 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4533 *next_code_point
= test
;
4534 next_code_point
= &test
->next
;
4538 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4539 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4540 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4541 *next_code_point
= test
;
4542 next_code_point
= &test
->next
;
4544 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4545 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4546 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4547 *next_code_point
= test
;
4548 next_code_point
= &test
->next
;
4553 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4554 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4555 test
= runtime_error_ne (b2
, a1
, B_ERROR_1
);
4556 *next_code_point
= test
;
4557 next_code_point
= &test
->next
;
4561 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4562 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4563 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4564 *next_code_point
= test
;
4565 next_code_point
= &test
->next
;
4567 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4568 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4569 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4570 *next_code_point
= test
;
4571 next_code_point
= &test
->next
;
4580 /* Handle the reallocation, if needed. */
4584 gfc_code
*lhs_alloc
;
4586 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4587 *next_code_point
= lhs_alloc
;
4588 next_code_point
= &lhs_alloc
->next
;
4591 *next_code_point
= call
;
4592 if_limit
->next
= co_next
;
4594 /* Set up the BLAS call. */
4596 call
->op
= EXEC_CALL
;
4598 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4599 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4600 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4601 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4602 call
->resolved_sym
= call
->symtree
->n
.sym
;
4604 /* Argument TRANSA. */
4605 next
= gfc_get_actual_arglist ();
4606 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4609 call
->ext
.actual
= next
;
4611 /* Argument TRANSB. */
4613 next
= gfc_get_actual_arglist ();
4614 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4616 actual
->next
= next
;
4618 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4619 gfc_integer_4_kind
);
4620 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4621 gfc_integer_4_kind
);
4623 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4624 gfc_integer_4_kind
);
4628 next
= gfc_get_actual_arglist ();
4630 actual
->next
= next
;
4634 next
= gfc_get_actual_arglist ();
4636 actual
->next
= next
;
4640 next
= gfc_get_actual_arglist ();
4642 actual
->next
= next
;
4644 /* Argument ALPHA - set to one. */
4646 next
= gfc_get_actual_arglist ();
4647 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4648 if (type
== BT_REAL
)
4649 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4651 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4652 actual
->next
= next
;
4656 next
= gfc_get_actual_arglist ();
4657 next
->expr
= gfc_copy_expr (matrix_a
);
4658 actual
->next
= next
;
4662 next
= gfc_get_actual_arglist ();
4663 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4664 1, gfc_integer_4_kind
);
4665 actual
->next
= next
;
4669 next
= gfc_get_actual_arglist ();
4670 next
->expr
= gfc_copy_expr (matrix_b
);
4671 actual
->next
= next
;
4675 next
= gfc_get_actual_arglist ();
4676 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4677 1, gfc_integer_4_kind
);
4678 actual
->next
= next
;
4680 /* Argument BETA - set to zero. */
4682 next
= gfc_get_actual_arglist ();
4683 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4684 if (type
== BT_REAL
)
4685 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4687 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4688 actual
->next
= next
;
4693 next
= gfc_get_actual_arglist ();
4694 next
->expr
= gfc_copy_expr (expr1
);
4695 actual
->next
= next
;
4699 next
= gfc_get_actual_arglist ();
4700 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4701 1, gfc_integer_4_kind
);
4702 actual
->next
= next
;
4708 /* Code for index interchange for loops which are grouped together in DO
4709 CONCURRENT or FORALL statements. This is currently only applied if the
4710 iterations are grouped together in a single statement.
4712 For this transformation, it is assumed that memory access in strides is
4713 expensive, and that loops which access later indices (which access memory
4714 in bigger strides) should be moved to the first loops.
4716 For this, a loop over all the statements is executed, counting the times
4717 that the loop iteration values are accessed in each index. The loop
4718 indices are then sorted to minimize access to later indices from inner
4721 /* Type for holding index information. */
4725 gfc_forall_iterator
*fa
;
4727 int n
[GFC_MAX_DIMENSIONS
];
4730 /* Callback function to determine if an expression is the
4731 corresponding variable. */
4734 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4736 gfc_expr
*expr
= *e
;
4739 if (expr
->expr_type
!= EXPR_VARIABLE
)
4742 sym
= (gfc_symbol
*) data
;
4743 return sym
== expr
->symtree
->n
.sym
;
4746 /* Callback function to calculate the cost of a certain index. */
4749 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4759 if (expr
->expr_type
!= EXPR_VARIABLE
)
4763 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4765 if (ref
->type
== REF_ARRAY
)
4771 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4774 ind
= (ind_type
*) data
;
4775 for (i
= 0; i
< ar
->dimen
; i
++)
4777 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4779 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4786 /* Callback function for qsort, to sort the loop indices. */
4789 loop_comp (const void *e1
, const void *e2
)
4791 const ind_type
*i1
= (const ind_type
*) e1
;
4792 const ind_type
*i2
= (const ind_type
*) e2
;
4795 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4797 if (i1
->n
[i
] != i2
->n
[i
])
4798 return i1
->n
[i
] - i2
->n
[i
];
4800 /* All other things being equal, let's not change the ordering. */
4801 return i2
->num
- i1
->num
;
4804 /* Main function to do the index interchange. */
4807 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4808 void *data ATTRIBUTE_UNUSED
)
4813 gfc_forall_iterator
*fa
;
4817 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4821 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4824 /* Nothing to reorder. */
4828 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4831 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4833 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4835 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4840 ind
[n_iter
].sym
= NULL
;
4841 ind
[n_iter
].fa
= NULL
;
4843 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4844 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4846 /* Do the actual index interchange. */
4847 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4848 for (i
=1; i
<n_iter
; i
++)
4850 fa
->next
= ind
[i
].fa
;
4855 if (flag_warn_frontend_loop_interchange
)
4857 for (i
=1; i
<n_iter
; i
++)
4859 if (ind
[i
-1].num
> ind
[i
].num
)
4861 gfc_warning (OPT_Wfrontend_loop_interchange
,
4862 "Interchanging loops at %L", &co
->loc
);
4871 #define WALK_SUBEXPR(NODE) \
4874 result = gfc_expr_walker (&(NODE), exprfn, data); \
4879 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4881 /* Walk expression *E, calling EXPRFN on each expression in it. */
4884 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4888 int walk_subtrees
= 1;
4889 gfc_actual_arglist
*a
;
4893 int result
= exprfn (e
, &walk_subtrees
, data
);
4897 switch ((*e
)->expr_type
)
4900 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4901 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4904 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4905 WALK_SUBEXPR (a
->expr
);
4909 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4910 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4911 WALK_SUBEXPR (a
->expr
);
4914 case EXPR_STRUCTURE
:
4916 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4917 c
= gfc_constructor_next (c
))
4919 if (c
->iterator
== NULL
)
4920 WALK_SUBEXPR (c
->expr
);
4924 WALK_SUBEXPR (c
->expr
);
4926 WALK_SUBEXPR (c
->iterator
->var
);
4927 WALK_SUBEXPR (c
->iterator
->start
);
4928 WALK_SUBEXPR (c
->iterator
->end
);
4929 WALK_SUBEXPR (c
->iterator
->step
);
4933 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4936 /* Fall through to the variable case in order to walk the
4940 case EXPR_SUBSTRING
:
4942 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4951 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4953 for (i
=0; i
< ar
->dimen
; i
++)
4955 WALK_SUBEXPR (ar
->start
[i
]);
4956 WALK_SUBEXPR (ar
->end
[i
]);
4957 WALK_SUBEXPR (ar
->stride
[i
]);
4964 WALK_SUBEXPR (r
->u
.ss
.start
);
4965 WALK_SUBEXPR (r
->u
.ss
.end
);
4982 #define WALK_SUBCODE(NODE) \
4985 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4991 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4992 on each expression in it. If any of the hooks returns non-zero, that
4993 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4994 no subcodes or subexpressions are traversed. */
4997 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5000 for (; *c
; c
= &(*c
)->next
)
5002 int walk_subtrees
= 1;
5003 int result
= codefn (c
, &walk_subtrees
, data
);
5010 gfc_actual_arglist
*a
;
5012 gfc_association_list
*alist
;
5013 bool saved_in_omp_workshare
;
5014 bool saved_in_where
;
5016 /* There might be statement insertions before the current code,
5017 which must not affect the expression walker. */
5020 saved_in_omp_workshare
= in_omp_workshare
;
5021 saved_in_where
= in_where
;
5027 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5028 if (co
->ext
.block
.assoc
)
5030 bool saved_in_assoc_list
= in_assoc_list
;
5032 in_assoc_list
= true;
5033 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5034 WALK_SUBEXPR (alist
->target
);
5036 in_assoc_list
= saved_in_assoc_list
;
5043 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5044 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5045 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5046 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5058 case EXEC_ASSIGN_CALL
:
5059 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5060 WALK_SUBEXPR (a
->expr
);
5064 WALK_SUBEXPR (co
->expr1
);
5065 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5066 WALK_SUBEXPR (a
->expr
);
5070 WALK_SUBEXPR (co
->expr1
);
5072 for (b
= co
->block
; b
; b
= b
->block
)
5075 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5077 WALK_SUBEXPR (cp
->low
);
5078 WALK_SUBEXPR (cp
->high
);
5080 WALK_SUBCODE (b
->next
);
5085 case EXEC_DEALLOCATE
:
5088 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5089 WALK_SUBEXPR (a
->expr
);
5094 case EXEC_DO_CONCURRENT
:
5096 gfc_forall_iterator
*fa
;
5097 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5099 WALK_SUBEXPR (fa
->var
);
5100 WALK_SUBEXPR (fa
->start
);
5101 WALK_SUBEXPR (fa
->end
);
5102 WALK_SUBEXPR (fa
->stride
);
5104 if (co
->op
== EXEC_FORALL
)
5110 WALK_SUBEXPR (co
->ext
.open
->unit
);
5111 WALK_SUBEXPR (co
->ext
.open
->file
);
5112 WALK_SUBEXPR (co
->ext
.open
->status
);
5113 WALK_SUBEXPR (co
->ext
.open
->access
);
5114 WALK_SUBEXPR (co
->ext
.open
->form
);
5115 WALK_SUBEXPR (co
->ext
.open
->recl
);
5116 WALK_SUBEXPR (co
->ext
.open
->blank
);
5117 WALK_SUBEXPR (co
->ext
.open
->position
);
5118 WALK_SUBEXPR (co
->ext
.open
->action
);
5119 WALK_SUBEXPR (co
->ext
.open
->delim
);
5120 WALK_SUBEXPR (co
->ext
.open
->pad
);
5121 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5122 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5123 WALK_SUBEXPR (co
->ext
.open
->convert
);
5124 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5125 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5126 WALK_SUBEXPR (co
->ext
.open
->round
);
5127 WALK_SUBEXPR (co
->ext
.open
->sign
);
5128 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5129 WALK_SUBEXPR (co
->ext
.open
->id
);
5130 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5131 WALK_SUBEXPR (co
->ext
.open
->share
);
5132 WALK_SUBEXPR (co
->ext
.open
->cc
);
5136 WALK_SUBEXPR (co
->ext
.close
->unit
);
5137 WALK_SUBEXPR (co
->ext
.close
->status
);
5138 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5139 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5142 case EXEC_BACKSPACE
:
5146 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5147 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5148 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5152 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5153 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5154 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5155 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5156 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5157 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5158 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5159 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5160 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5161 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5162 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5163 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5164 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5165 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5166 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5167 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5168 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5169 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5170 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5171 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5172 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5173 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5174 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5175 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5176 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5177 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5178 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5179 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5180 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5181 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5182 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5183 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5184 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5185 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5186 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5187 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5191 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5192 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5193 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5194 WALK_SUBEXPR (co
->ext
.wait
->id
);
5199 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5200 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5201 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5202 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5203 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5204 WALK_SUBEXPR (co
->ext
.dt
->size
);
5205 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5206 WALK_SUBEXPR (co
->ext
.dt
->id
);
5207 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5208 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5209 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5210 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5211 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5212 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5213 WALK_SUBEXPR (co
->ext
.dt
->round
);
5214 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5215 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5218 case EXEC_OMP_PARALLEL
:
5219 case EXEC_OMP_PARALLEL_DO
:
5220 case EXEC_OMP_PARALLEL_DO_SIMD
:
5221 case EXEC_OMP_PARALLEL_SECTIONS
:
5223 in_omp_workshare
= false;
5225 /* This goto serves as a shortcut to avoid code
5226 duplication or a larger if or switch statement. */
5227 goto check_omp_clauses
;
5229 case EXEC_OMP_WORKSHARE
:
5230 case EXEC_OMP_PARALLEL_WORKSHARE
:
5232 in_omp_workshare
= true;
5236 case EXEC_OMP_CRITICAL
:
5237 case EXEC_OMP_DISTRIBUTE
:
5238 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5239 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5240 case EXEC_OMP_DISTRIBUTE_SIMD
:
5242 case EXEC_OMP_DO_SIMD
:
5243 case EXEC_OMP_ORDERED
:
5244 case EXEC_OMP_SECTIONS
:
5245 case EXEC_OMP_SINGLE
:
5246 case EXEC_OMP_END_SINGLE
:
5248 case EXEC_OMP_TASKLOOP
:
5249 case EXEC_OMP_TASKLOOP_SIMD
:
5250 case EXEC_OMP_TARGET
:
5251 case EXEC_OMP_TARGET_DATA
:
5252 case EXEC_OMP_TARGET_ENTER_DATA
:
5253 case EXEC_OMP_TARGET_EXIT_DATA
:
5254 case EXEC_OMP_TARGET_PARALLEL
:
5255 case EXEC_OMP_TARGET_PARALLEL_DO
:
5256 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5257 case EXEC_OMP_TARGET_SIMD
:
5258 case EXEC_OMP_TARGET_TEAMS
:
5259 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5260 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5261 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5262 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5263 case EXEC_OMP_TARGET_UPDATE
:
5265 case EXEC_OMP_TEAMS
:
5266 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5267 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5268 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5269 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5271 /* Come to this label only from the
5272 EXEC_OMP_PARALLEL_* cases above. */
5276 if (co
->ext
.omp_clauses
)
5278 gfc_omp_namelist
*n
;
5279 static int list_types
[]
5280 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5281 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5283 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5284 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5285 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5286 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5287 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5288 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5289 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5290 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5291 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5292 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5293 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5294 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5295 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5296 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5297 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5298 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5300 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5302 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5304 WALK_SUBEXPR (n
->expr
);
5311 WALK_SUBEXPR (co
->expr1
);
5312 WALK_SUBEXPR (co
->expr2
);
5313 WALK_SUBEXPR (co
->expr3
);
5314 WALK_SUBEXPR (co
->expr4
);
5315 for (b
= co
->block
; b
; b
= b
->block
)
5317 WALK_SUBEXPR (b
->expr1
);
5318 WALK_SUBEXPR (b
->expr2
);
5319 WALK_SUBCODE (b
->next
);
5322 if (co
->op
== EXEC_FORALL
)
5325 if (co
->op
== EXEC_DO
)
5328 if (co
->op
== EXEC_IF
)
5331 if (co
->op
== EXEC_SELECT
)
5334 in_omp_workshare
= saved_in_omp_workshare
;
5335 in_where
= saved_in_where
;