1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2017 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 bool has_dimen_vector_ref (gfc_expr
*);
57 static int matmul_temp_args (gfc_code
**, int *,void *data
);
58 static int index_interchange (gfc_code
**, int*, void *);
61 static void check_locus (gfc_namespace
*);
64 /* How deep we are inside an argument list. */
66 static int count_arglist
;
68 /* Vector of gfc_expr ** we operate on. */
70 static vec
<gfc_expr
**> expr_array
;
72 /* Pointer to the gfc_code we currently work on - to be able to insert
73 a block before the statement. */
75 static gfc_code
**current_code
;
77 /* Pointer to the block to be inserted, and the statement we are
78 changing within the block. */
80 static gfc_code
*inserted_block
, **changed_statement
;
82 /* The namespace we are currently dealing with. */
84 static gfc_namespace
*current_ns
;
86 /* If we are within any forall loop. */
88 static int forall_level
;
90 /* Keep track of whether we are within an OMP workshare. */
92 static bool in_omp_workshare
;
94 /* Keep track of whether we are within a WHERE statement. */
98 /* Keep track of iterators for array constructors. */
100 static int iterator_level
;
102 /* Keep track of DO loop levels. */
110 static vec
<do_t
> doloop_list
;
111 static int doloop_level
;
113 /* Keep track of if and select case levels. */
116 static int select_level
;
118 /* Vector of gfc_expr * to keep track of DO loops. */
120 struct my_struct
*evec
;
122 /* Keep track of association lists. */
124 static bool in_assoc_list
;
126 /* Counter for temporary variables. */
128 static int var_num
= 1;
130 /* What sort of matrix we are dealing with when inlining MATMUL. */
132 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
134 /* Keep track of the number of expressions we have inserted so far
139 /* Entry point - run all passes for a namespace. */
142 gfc_run_passes (gfc_namespace
*ns
)
145 /* Warn about dubious DO loops where the index might
152 doloop_list
.release ();
159 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
160 optimize_namespace (ns
);
162 if (flag_frontend_optimize
)
164 optimize_reduction (ns
);
165 if (flag_dump_fortran_optimized
)
166 gfc_dump_parse_tree (ns
, stdout
);
168 expr_array
.release ();
171 gfc_get_errors (&w
, &e
);
175 if (flag_realloc_lhs
)
176 realloc_strings (ns
);
181 /* Callback function: Warn if there is no location information in a
185 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
186 void *data ATTRIBUTE_UNUSED
)
189 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
190 gfc_warning_internal (0, "No location in statement");
196 /* Callback function: Warn if there is no location information in an
200 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
201 void *data ATTRIBUTE_UNUSED
)
204 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
205 gfc_warning_internal (0, "No location in expression near %L",
206 &((*current_code
)->loc
));
210 /* Run check for missing location information. */
213 check_locus (gfc_namespace
*ns
)
215 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
217 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
219 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
226 /* Callback for each gfc_code node invoked from check_realloc_strings.
227 For an allocatable LHS string which also appears as a variable on
239 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
240 void *data ATTRIBUTE_UNUSED
)
242 gfc_expr
*expr1
, *expr2
;
248 if (co
->op
!= EXEC_ASSIGN
)
252 if (expr1
->ts
.type
!= BT_CHARACTER
253 || !gfc_expr_attr(expr1
).allocatable
254 || !expr1
->ts
.deferred
)
257 expr2
= gfc_discard_nops (co
->expr2
);
259 if (expr2
->expr_type
== EXPR_VARIABLE
)
261 found_substr
= false;
262 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
264 if (ref
->type
== REF_SUBSTRING
)
273 else if (expr2
->expr_type
!= EXPR_ARRAY
274 && (expr2
->expr_type
!= EXPR_OP
275 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
278 if (!gfc_check_dependency (expr1
, expr2
, true))
281 /* gfc_check_dependency doesn't always pick up identical expressions.
282 However, eliminating the above sends the compiler into an infinite
283 loop on valid expressions. Without this check, the gimplifier emits
284 an ICE for a = a, where a is deferred character length. */
285 if (!gfc_dep_compare_expr (expr1
, expr2
))
289 inserted_block
= NULL
;
290 changed_statement
= NULL
;
291 n
= create_var (expr2
, "realloc_string");
296 /* Callback for each gfc_code node invoked through gfc_code_walker
297 from optimize_namespace. */
300 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
301 void *data ATTRIBUTE_UNUSED
)
308 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
309 || op
== EXEC_CALL_PPC
)
315 inserted_block
= NULL
;
316 changed_statement
= NULL
;
318 if (op
== EXEC_ASSIGN
)
319 optimize_assignment (*c
);
323 /* Callback for each gfc_expr node invoked through gfc_code_walker
324 from optimize_namespace. */
327 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
328 void *data ATTRIBUTE_UNUSED
)
332 if ((*e
)->expr_type
== EXPR_FUNCTION
)
335 function_expr
= true;
338 function_expr
= false;
340 if (optimize_trim (*e
))
341 gfc_simplify_expr (*e
, 0);
343 if (optimize_lexical_comparison (*e
))
344 gfc_simplify_expr (*e
, 0);
346 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
347 gfc_simplify_expr (*e
, 0);
349 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
350 switch ((*e
)->value
.function
.isym
->id
)
352 case GFC_ISYM_MINLOC
:
353 case GFC_ISYM_MAXLOC
:
354 optimize_minmaxloc (e
);
366 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
367 function is a scalar, just copy it; otherwise returns the new element, the
368 old one can be freed. */
371 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
373 gfc_expr
*fcn
, *e
= c
->expr
;
375 fcn
= gfc_copy_expr (e
);
378 gfc_constructor_base newbase
;
380 gfc_constructor
*new_c
;
383 new_expr
= gfc_get_expr ();
384 new_expr
->expr_type
= EXPR_ARRAY
;
385 new_expr
->ts
= e
->ts
;
386 new_expr
->where
= e
->where
;
388 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
389 new_c
->iterator
= c
->iterator
;
390 new_expr
->value
.constructor
= newbase
;
398 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
400 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
401 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
402 fn
->value
.function
.isym
->name
,
403 fn
->where
, 3, fcn
, NULL
, NULL
);
404 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
405 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
406 fn
->value
.function
.isym
->name
,
407 fn
->where
, 2, fcn
, NULL
);
409 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
411 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
417 /* Callback function for optimzation of reductions to scalars. Transform ANY
418 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
419 correspondingly. Handly only the simple cases without MASK and DIM. */
422 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
423 void *data ATTRIBUTE_UNUSED
)
428 gfc_actual_arglist
*a
;
429 gfc_actual_arglist
*dim
;
431 gfc_expr
*res
, *new_expr
;
432 gfc_actual_arglist
*mask
;
436 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
437 || fn
->value
.function
.isym
== NULL
)
440 id
= fn
->value
.function
.isym
->id
;
442 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
443 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
446 a
= fn
->value
.function
.actual
;
448 /* Don't handle MASK or DIM. */
452 if (dim
->expr
!= NULL
)
455 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
458 if ( mask
->expr
!= NULL
)
464 if (arg
->expr_type
!= EXPR_ARRAY
)
473 case GFC_ISYM_PRODUCT
:
474 op
= INTRINSIC_TIMES
;
489 c
= gfc_constructor_first (arg
->value
.constructor
);
491 /* Don't do any simplififcation if we have
492 - no element in the constructor or
493 - only have a single element in the array which contains an
499 res
= copy_walk_reduction_arg (c
, fn
);
501 c
= gfc_constructor_next (c
);
504 new_expr
= gfc_get_expr ();
505 new_expr
->ts
= fn
->ts
;
506 new_expr
->expr_type
= EXPR_OP
;
507 new_expr
->rank
= fn
->rank
;
508 new_expr
->where
= fn
->where
;
509 new_expr
->value
.op
.op
= op
;
510 new_expr
->value
.op
.op1
= res
;
511 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
513 c
= gfc_constructor_next (c
);
516 gfc_simplify_expr (res
, 0);
523 /* Callback function for common function elimination, called from cfe_expr_0.
524 Put all eligible function expressions into expr_array. */
527 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
528 void *data ATTRIBUTE_UNUSED
)
531 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
534 /* We don't do character functions with unknown charlens. */
535 if ((*e
)->ts
.type
== BT_CHARACTER
536 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
537 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
540 /* We don't do function elimination within FORALL statements, it can
541 lead to wrong-code in certain circumstances. */
543 if (forall_level
> 0)
546 /* Function elimination inside an iterator could lead to functions which
547 depend on iterator variables being moved outside. FIXME: We should check
548 if the functions do indeed depend on the iterator variable. */
550 if (iterator_level
> 0)
553 /* If we don't know the shape at compile time, we create an allocatable
554 temporary variable to hold the intermediate result, but only if
555 allocation on assignment is active. */
557 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
560 /* Skip the test for pure functions if -faggressive-function-elimination
562 if ((*e
)->value
.function
.esym
)
564 /* Don't create an array temporary for elemental functions. */
565 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
568 /* Only eliminate potentially impure functions if the
569 user specifically requested it. */
570 if (!flag_aggressive_function_elimination
571 && !(*e
)->value
.function
.esym
->attr
.pure
572 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
576 if ((*e
)->value
.function
.isym
)
578 /* Conversions are handled on the fly by the middle end,
579 transpose during trans-* stages and TRANSFER by the middle end. */
580 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
581 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
582 || gfc_inline_intrinsic_function_p (*e
))
585 /* Don't create an array temporary for elemental functions,
586 as this would be wasteful of memory.
587 FIXME: Create a scalar temporary during scalarization. */
588 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
591 if (!(*e
)->value
.function
.isym
->pure
)
595 expr_array
.safe_push (e
);
599 /* Auxiliary function to check if an expression is a temporary created by
603 is_fe_temp (gfc_expr
*e
)
605 if (e
->expr_type
!= EXPR_VARIABLE
)
608 return e
->symtree
->n
.sym
->attr
.fe_temp
;
611 /* Determine the length of a string, if it can be evaluated as a constant
612 expression. Return a newly allocated gfc_expr or NULL on failure.
613 If the user specified a substring which is potentially longer than
614 the string itself, the string will be padded with spaces, which
618 constant_string_length (gfc_expr
*e
)
628 length
= e
->ts
.u
.cl
->length
;
629 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
630 return gfc_copy_expr(length
);
633 /* Return length of substring, if constant. */
634 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
636 if (ref
->type
== REF_SUBSTRING
637 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
639 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
642 mpz_add_ui (res
->value
.integer
, value
, 1);
648 /* Return length of char symbol, if constant. */
650 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
651 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
652 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
653 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
659 /* Insert a block at the current position unless it has already
660 been inserted; in this case use the one already there. */
662 static gfc_namespace
*
667 /* If the block hasn't already been created, do so. */
668 if (inserted_block
== NULL
)
670 inserted_block
= XCNEW (gfc_code
);
671 inserted_block
->op
= EXEC_BLOCK
;
672 inserted_block
->loc
= (*current_code
)->loc
;
673 ns
= gfc_build_block_ns (current_ns
);
674 inserted_block
->ext
.block
.ns
= ns
;
675 inserted_block
->ext
.block
.assoc
= NULL
;
677 ns
->code
= *current_code
;
679 /* If the statement has a label, make sure it is transferred to
680 the newly created block. */
682 if ((*current_code
)->here
)
684 inserted_block
->here
= (*current_code
)->here
;
685 (*current_code
)->here
= NULL
;
688 inserted_block
->next
= (*current_code
)->next
;
689 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
690 (*current_code
)->next
= NULL
;
691 /* Insert the BLOCK at the right position. */
692 *current_code
= inserted_block
;
693 ns
->parent
= current_ns
;
696 ns
= inserted_block
->ext
.block
.ns
;
701 /* Returns a new expression (a variable) to be used in place of the old one,
702 with an optional assignment statement before the current statement to set
703 the value of the variable. Creates a new BLOCK for the statement if that
704 hasn't already been done and puts the statement, plus the newly created
705 variables, in that block. Special cases: If the expression is constant or
706 a temporary which has already been created, just copy it. */
709 create_var (gfc_expr
* e
, const char *vname
)
711 char name
[GFC_MAX_SYMBOL_LEN
+1];
712 gfc_symtree
*symtree
;
720 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
721 return gfc_copy_expr (e
);
723 ns
= insert_block ();
726 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
728 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
730 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
733 symbol
= symtree
->n
.sym
;
738 symbol
->as
= gfc_get_array_spec ();
739 symbol
->as
->rank
= e
->rank
;
741 if (e
->shape
== NULL
)
743 /* We don't know the shape at compile time, so we use an
745 symbol
->as
->type
= AS_DEFERRED
;
746 symbol
->attr
.allocatable
= 1;
750 symbol
->as
->type
= AS_EXPLICIT
;
751 /* Copy the shape. */
752 for (i
=0; i
<e
->rank
; i
++)
756 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
758 mpz_set_si (p
->value
.integer
, 1);
759 symbol
->as
->lower
[i
] = p
;
761 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
763 mpz_set (q
->value
.integer
, e
->shape
[i
]);
764 symbol
->as
->upper
[i
] = q
;
770 if (e
->ts
.type
== BT_CHARACTER
)
774 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
775 length
= constant_string_length (e
);
777 symbol
->ts
.u
.cl
->length
= length
;
780 symbol
->attr
.allocatable
= 1;
781 symbol
->ts
.u
.cl
->length
= NULL
;
782 symbol
->ts
.deferred
= 1;
787 symbol
->attr
.flavor
= FL_VARIABLE
;
788 symbol
->attr
.referenced
= 1;
789 symbol
->attr
.dimension
= e
->rank
> 0;
790 symbol
->attr
.fe_temp
= 1;
791 gfc_commit_symbol (symbol
);
793 result
= gfc_get_expr ();
794 result
->expr_type
= EXPR_VARIABLE
;
795 result
->ts
= symbol
->ts
;
796 result
->ts
.deferred
= deferred
;
797 result
->rank
= e
->rank
;
798 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
799 result
->symtree
= symtree
;
800 result
->where
= e
->where
;
803 result
->ref
= gfc_get_ref ();
804 result
->ref
->type
= REF_ARRAY
;
805 result
->ref
->u
.ar
.type
= AR_FULL
;
806 result
->ref
->u
.ar
.where
= e
->where
;
807 result
->ref
->u
.ar
.dimen
= e
->rank
;
808 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
809 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
810 if (warn_array_temporaries
)
811 gfc_warning (OPT_Warray_temporaries
,
812 "Creating array temporary at %L", &(e
->where
));
815 /* Generate the new assignment. */
816 n
= XCNEW (gfc_code
);
818 n
->loc
= (*current_code
)->loc
;
819 n
->next
= *changed_statement
;
820 n
->expr1
= gfc_copy_expr (result
);
822 *changed_statement
= n
;
828 /* Warn about function elimination. */
831 do_warn_function_elimination (gfc_expr
*e
)
833 if (e
->expr_type
!= EXPR_FUNCTION
)
835 if (e
->value
.function
.esym
)
836 gfc_warning (OPT_Wfunction_elimination
,
837 "Removing call to function %qs at %L",
838 e
->value
.function
.esym
->name
, &(e
->where
));
839 else if (e
->value
.function
.isym
)
840 gfc_warning (OPT_Wfunction_elimination
,
841 "Removing call to function %qs at %L",
842 e
->value
.function
.isym
->name
, &(e
->where
));
844 /* Callback function for the code walker for doing common function
845 elimination. This builds up the list of functions in the expression
846 and goes through them to detect duplicates, which it then replaces
850 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
851 void *data ATTRIBUTE_UNUSED
)
857 /* Don't do this optimization within OMP workshare or ASSOC lists. */
859 if (in_omp_workshare
|| in_assoc_list
)
865 expr_array
.release ();
867 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
869 /* Walk through all the functions. */
871 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
873 /* Skip if the function has been replaced by a variable already. */
874 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
881 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
884 newvar
= create_var (*ei
, "fcn");
886 if (warn_function_elimination
)
887 do_warn_function_elimination (*ej
);
890 *ej
= gfc_copy_expr (newvar
);
897 /* We did all the necessary walking in this function. */
902 /* Callback function for common function elimination, called from
903 gfc_code_walker. This keeps track of the current code, in order
904 to insert statements as needed. */
907 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
910 inserted_block
= NULL
;
911 changed_statement
= NULL
;
913 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
914 and allocation on assigment are prohibited inside WHERE, and finally
915 masking an expression would lead to wrong-code when replacing
918 b = sum(foo(a) + foo(a))
929 if ((*c
)->op
== EXEC_WHERE
)
939 /* Dummy function for expression call back, for use when we
940 really don't want to do any walking. */
943 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
944 void *data ATTRIBUTE_UNUSED
)
950 /* Dummy function for code callback, for use when we really
951 don't want to do anything. */
953 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
954 int *walk_subtrees ATTRIBUTE_UNUSED
,
955 void *data ATTRIBUTE_UNUSED
)
960 /* Code callback function for converting
967 This is because common function elimination would otherwise place the
968 temporary variables outside the loop. */
971 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
972 void *data ATTRIBUTE_UNUSED
)
975 gfc_code
*c_if1
, *c_if2
, *c_exit
;
977 gfc_expr
*e_not
, *e_cond
;
979 if (co
->op
!= EXEC_DO_WHILE
)
982 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
987 /* Generate the condition of the if statement, which is .not. the original
989 e_not
= gfc_get_expr ();
990 e_not
->ts
= e_cond
->ts
;
991 e_not
->where
= e_cond
->where
;
992 e_not
->expr_type
= EXPR_OP
;
993 e_not
->value
.op
.op
= INTRINSIC_NOT
;
994 e_not
->value
.op
.op1
= e_cond
;
996 /* Generate the EXIT statement. */
997 c_exit
= XCNEW (gfc_code
);
998 c_exit
->op
= EXEC_EXIT
;
999 c_exit
->ext
.which_construct
= co
;
1000 c_exit
->loc
= co
->loc
;
1002 /* Generate the IF statement. */
1003 c_if2
= XCNEW (gfc_code
);
1004 c_if2
->op
= EXEC_IF
;
1005 c_if2
->expr1
= e_not
;
1006 c_if2
->next
= c_exit
;
1007 c_if2
->loc
= co
->loc
;
1009 /* ... plus the one to chain it to. */
1010 c_if1
= XCNEW (gfc_code
);
1011 c_if1
->op
= EXEC_IF
;
1012 c_if1
->block
= c_if2
;
1013 c_if1
->loc
= co
->loc
;
1015 /* Make the DO WHILE loop into a DO block by replacing the condition
1016 with a true constant. */
1017 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1019 /* Hang the generated if statement into the loop body. */
1021 loopblock
= co
->block
->next
;
1022 co
->block
->next
= c_if1
;
1023 c_if1
->next
= loopblock
;
1028 /* Code callback function for converting
1041 because otherwise common function elimination would place the BLOCKs
1042 into the wrong place. */
1045 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1046 void *data ATTRIBUTE_UNUSED
)
1049 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1051 if (co
->op
!= EXEC_IF
)
1054 /* This loop starts out with the first ELSE statement. */
1055 else_stmt
= co
->block
->block
;
1057 while (else_stmt
!= NULL
)
1059 gfc_code
*next_else
;
1061 /* If there is no condition, we're done. */
1062 if (else_stmt
->expr1
== NULL
)
1065 next_else
= else_stmt
->block
;
1067 /* Generate the new IF statement. */
1068 c_if2
= XCNEW (gfc_code
);
1069 c_if2
->op
= EXEC_IF
;
1070 c_if2
->expr1
= else_stmt
->expr1
;
1071 c_if2
->next
= else_stmt
->next
;
1072 c_if2
->loc
= else_stmt
->loc
;
1073 c_if2
->block
= next_else
;
1075 /* ... plus the one to chain it to. */
1076 c_if1
= XCNEW (gfc_code
);
1077 c_if1
->op
= EXEC_IF
;
1078 c_if1
->block
= c_if2
;
1079 c_if1
->loc
= else_stmt
->loc
;
1081 /* Insert the new IF after the ELSE. */
1082 else_stmt
->expr1
= NULL
;
1083 else_stmt
->next
= c_if1
;
1084 else_stmt
->block
= NULL
;
1086 else_stmt
= next_else
;
1088 /* Don't walk subtrees. */
1094 struct do_stack
*prev
;
1099 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1100 optimize by replacing do loops with their analog array slices. For
1103 write (*,*) (a(i), i=1,4)
1107 write (*,*) a(1:4:1) . */
1110 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1113 gfc_expr
*new_e
, *expr
, *start
;
1115 struct do_stack ds_push
;
1116 int i
, future_rank
= 0;
1117 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1120 /* Find the first transfer/do statement. */
1121 for (curr
= code
; curr
; curr
= curr
->next
)
1123 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1127 /* Ensure it is the only transfer/do statement because cases like
1129 write (*,*) (a(i), b(i), i=1,4)
1131 cannot be optimized. */
1133 if (!curr
|| curr
->next
)
1136 if (curr
->op
== EXEC_DO
)
1138 if (curr
->ext
.iterator
->var
->ref
)
1140 ds_push
.prev
= stack_top
;
1141 ds_push
.iter
= curr
->ext
.iterator
;
1142 ds_push
.code
= curr
;
1143 stack_top
= &ds_push
;
1144 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1146 if (curr
!= stack_top
->code
&& !*has_reached
)
1148 curr
->block
->next
= NULL
;
1149 gfc_free_statements (curr
);
1152 *has_reached
= true;
1158 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1160 /* FIXME: Workaround for PR 80945 - array slices with deferred character
1161 lenghts do not work. Remove this section when the PR is fixed. */
1163 if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
1166 /* End of section to be removed. */
1169 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1172 /* Find the iterators belonging to each variable and check conditions. */
1173 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1175 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1176 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1179 start
= ref
->u
.ar
.start
[i
];
1180 gfc_simplify_expr (start
, 0);
1181 switch (start
->expr_type
)
1185 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1189 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1190 if (!stack_top
|| !stack_top
->iter
1191 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1193 /* Check for (a(i,i), i=1,3). */
1197 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1204 iters
[i
] = stack_top
->iter
;
1205 stack_top
= stack_top
->prev
;
1213 switch (start
->value
.op
.op
)
1215 case INTRINSIC_PLUS
:
1216 case INTRINSIC_TIMES
:
1217 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1218 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1220 case INTRINSIC_MINUS
:
1221 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1222 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1223 || start
->value
.op
.op1
->ref
)
1225 if (!stack_top
|| !stack_top
->iter
1226 || stack_top
->iter
->var
->symtree
1227 != start
->value
.op
.op1
->symtree
)
1229 iters
[i
] = stack_top
->iter
;
1230 stack_top
= stack_top
->prev
;
1242 /* Create new expr. */
1243 new_e
= gfc_copy_expr (curr
->expr1
);
1244 new_e
->expr_type
= EXPR_VARIABLE
;
1245 new_e
->rank
= future_rank
;
1246 if (curr
->expr1
->shape
)
1247 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1249 /* Assign new starts, ends and strides if necessary. */
1250 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1254 start
= ref
->u
.ar
.start
[i
];
1255 switch (start
->expr_type
)
1258 gfc_internal_error ("bad expression");
1261 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1262 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1263 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1264 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1265 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1266 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1269 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1270 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1271 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1272 expr
= gfc_copy_expr (start
);
1273 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1274 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1275 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1276 expr
= gfc_copy_expr (start
);
1277 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1278 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1279 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1280 switch (start
->value
.op
.op
)
1282 case INTRINSIC_MINUS
:
1283 case INTRINSIC_PLUS
:
1284 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1286 case INTRINSIC_TIMES
:
1287 expr
= gfc_copy_expr (start
);
1288 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1289 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1290 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1293 gfc_internal_error ("bad op");
1297 gfc_internal_error ("bad expression");
1300 curr
->expr1
= new_e
;
1302 /* Insert modified statement. Check whether the statement needs to be
1303 inserted at the lowest level. */
1304 if (!stack_top
->iter
)
1308 curr
->next
= prev
->next
->next
;
1313 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1314 stack_top
->code
->block
->next
= curr
;
1318 stack_top
->code
->block
->next
= curr
;
1322 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1323 tries to optimize its block. */
1326 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1327 void *data ATTRIBUTE_UNUSED
)
1329 gfc_code
**curr
, *prev
= NULL
;
1330 struct do_stack write
, first
;
1334 || ((*code
)->block
->op
!= EXEC_WRITE
1335 && (*code
)->block
->op
!= EXEC_READ
))
1343 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1345 if ((*curr
)->op
== EXEC_DO
)
1347 first
.prev
= &write
;
1348 first
.iter
= (*curr
)->ext
.iterator
;
1351 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1359 /* Optimize a namespace, including all contained namespaces.
1360 flag_frontend_optimize and flag_fronend_loop_interchange are
1361 handled separately. */
1364 optimize_namespace (gfc_namespace
*ns
)
1366 gfc_namespace
*saved_ns
= gfc_current_ns
;
1368 gfc_current_ns
= ns
;
1371 in_assoc_list
= false;
1372 in_omp_workshare
= false;
1374 if (flag_frontend_optimize
)
1376 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1377 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1378 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1379 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1380 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1381 if (flag_inline_matmul_limit
!= 0)
1387 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1392 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1394 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1399 if (flag_frontend_loop_interchange
)
1400 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1403 /* BLOCKs are handled in the expression walker below. */
1404 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1406 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1407 optimize_namespace (ns
);
1409 gfc_current_ns
= saved_ns
;
1412 /* Handle dependencies for allocatable strings which potentially redefine
1413 themselves in an assignment. */
1416 realloc_strings (gfc_namespace
*ns
)
1419 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1421 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1423 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1424 realloc_strings (ns
);
1430 optimize_reduction (gfc_namespace
*ns
)
1433 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1434 callback_reduction
, NULL
);
1436 /* BLOCKs are handled in the expression walker below. */
1437 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1439 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1440 optimize_reduction (ns
);
1444 /* Replace code like
1447 a = matmul(b,c) ; a = a + d
1448 where the array function is not elemental and not allocatable
1449 and does not depend on the left-hand side.
1453 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1461 if (e
->expr_type
== EXPR_OP
)
1463 switch (e
->value
.op
.op
)
1465 /* Unary operators and exponentiation: Only look at a single
1468 case INTRINSIC_UPLUS
:
1469 case INTRINSIC_UMINUS
:
1470 case INTRINSIC_PARENTHESES
:
1471 case INTRINSIC_POWER
:
1472 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1476 case INTRINSIC_CONCAT
:
1477 /* Do not do string concatenations. */
1481 /* Binary operators. */
1482 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1485 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1491 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1492 && ! (e
->value
.function
.esym
1493 && (e
->value
.function
.esym
->attr
.elemental
1494 || e
->value
.function
.esym
->attr
.allocatable
1495 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1496 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1497 && ! (e
->value
.function
.isym
1498 && (e
->value
.function
.isym
->elemental
1499 || e
->ts
.type
!= c
->expr1
->ts
.type
1500 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1501 && ! gfc_inline_intrinsic_function_p (e
))
1507 /* Insert a new assignment statement after the current one. */
1508 n
= XCNEW (gfc_code
);
1509 n
->op
= EXEC_ASSIGN
;
1514 n
->expr1
= gfc_copy_expr (c
->expr1
);
1515 n
->expr2
= c
->expr2
;
1516 new_expr
= gfc_copy_expr (c
->expr1
);
1524 /* Nothing to optimize. */
1528 /* Remove unneeded TRIMs at the end of expressions. */
1531 remove_trim (gfc_expr
*rhs
)
1539 /* Check for a // b // trim(c). Looping is probably not
1540 necessary because the parser usually generates
1541 (// (// a b ) trim(c) ) , but better safe than sorry. */
1543 while (rhs
->expr_type
== EXPR_OP
1544 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1545 rhs
= rhs
->value
.op
.op2
;
1547 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1548 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1550 strip_function_call (rhs
);
1551 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1559 /* Optimizations for an assignment. */
1562 optimize_assignment (gfc_code
* c
)
1564 gfc_expr
*lhs
, *rhs
;
1569 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1571 /* Optimize a = trim(b) to a = b. */
1574 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1575 if (is_empty_string (rhs
))
1576 rhs
->value
.character
.length
= 0;
1579 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1580 optimize_binop_array_assignment (c
, &rhs
, false);
1584 /* Remove an unneeded function call, modifying the expression.
1585 This replaces the function call with the value of its
1586 first argument. The rest of the argument list is freed. */
1589 strip_function_call (gfc_expr
*e
)
1592 gfc_actual_arglist
*a
;
1594 a
= e
->value
.function
.actual
;
1596 /* We should have at least one argument. */
1597 gcc_assert (a
->expr
!= NULL
);
1601 /* Free the remaining arglist, if any. */
1603 gfc_free_actual_arglist (a
->next
);
1605 /* Graft the argument expression onto the original function. */
1611 /* Optimization of lexical comparison functions. */
1614 optimize_lexical_comparison (gfc_expr
*e
)
1616 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1619 switch (e
->value
.function
.isym
->id
)
1622 return optimize_comparison (e
, INTRINSIC_LE
);
1625 return optimize_comparison (e
, INTRINSIC_GE
);
1628 return optimize_comparison (e
, INTRINSIC_GT
);
1631 return optimize_comparison (e
, INTRINSIC_LT
);
1639 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1640 do CHARACTER because of possible pessimization involving character
1644 combine_array_constructor (gfc_expr
*e
)
1647 gfc_expr
*op1
, *op2
;
1650 gfc_constructor
*c
, *new_c
;
1651 gfc_constructor_base oldbase
, newbase
;
1656 /* Array constructors have rank one. */
1660 /* Don't try to combine association lists, this makes no sense
1661 and leads to an ICE. */
1665 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1666 if (forall_level
> 0)
1669 /* Inside an iterator, things can get hairy; we are likely to create
1670 an invalid temporary variable. */
1671 if (iterator_level
> 0)
1674 op1
= e
->value
.op
.op1
;
1675 op2
= e
->value
.op
.op2
;
1680 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1681 scalar_first
= false;
1682 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1684 scalar_first
= true;
1685 op1
= e
->value
.op
.op2
;
1686 op2
= e
->value
.op
.op1
;
1691 if (op2
->ts
.type
== BT_CHARACTER
)
1694 /* This might be an expanded constructor with very many constant values. If
1695 we perform the operation here, we might end up with a long compile time
1696 and actually longer execution time, so a length bound is in order here.
1697 If the constructor constains something which is not a constant, it did
1698 not come from an expansion, so leave it alone. */
1700 #define CONSTR_LEN_MAX 4
1702 oldbase
= op1
->value
.constructor
;
1706 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1708 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1716 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1719 #undef CONSTR_LEN_MAX
1722 e
->expr_type
= EXPR_ARRAY
;
1724 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1726 for (c
= gfc_constructor_first (oldbase
); c
;
1727 c
= gfc_constructor_next (c
))
1729 new_expr
= gfc_get_expr ();
1730 new_expr
->ts
= e
->ts
;
1731 new_expr
->expr_type
= EXPR_OP
;
1732 new_expr
->rank
= c
->expr
->rank
;
1733 new_expr
->where
= c
->expr
->where
;
1734 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1738 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1739 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1743 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1744 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1747 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1748 new_c
->iterator
= c
->iterator
;
1752 gfc_free_expr (op1
);
1753 gfc_free_expr (op2
);
1754 gfc_free_expr (scalar
);
1756 e
->value
.constructor
= newbase
;
1760 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1761 2**k into ishift(1,k) */
1764 optimize_power (gfc_expr
*e
)
1766 gfc_expr
*op1
, *op2
;
1767 gfc_expr
*iand
, *ishft
;
1769 if (e
->ts
.type
!= BT_INTEGER
)
1772 op1
= e
->value
.op
.op1
;
1774 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1777 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1779 gfc_free_expr (op1
);
1781 op2
= e
->value
.op
.op2
;
1786 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1787 "_internal_iand", e
->where
, 2, op2
,
1788 gfc_get_int_expr (e
->ts
.kind
,
1791 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1792 "_internal_ishft", e
->where
, 2, iand
,
1793 gfc_get_int_expr (e
->ts
.kind
,
1796 e
->value
.op
.op
= INTRINSIC_MINUS
;
1797 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1798 e
->value
.op
.op2
= ishft
;
1801 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1803 gfc_free_expr (op1
);
1805 op2
= e
->value
.op
.op2
;
1809 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1810 "_internal_ishft", e
->where
, 2,
1811 gfc_get_int_expr (e
->ts
.kind
,
1818 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1820 op2
= e
->value
.op
.op2
;
1824 gfc_free_expr (op1
);
1825 gfc_free_expr (op2
);
1827 e
->expr_type
= EXPR_CONSTANT
;
1828 e
->value
.op
.op1
= NULL
;
1829 e
->value
.op
.op2
= NULL
;
1830 mpz_init_set_si (e
->value
.integer
, 1);
1831 /* Typespec and location are still OK. */
1838 /* Recursive optimization of operators. */
1841 optimize_op (gfc_expr
*e
)
1845 gfc_intrinsic_op op
= e
->value
.op
.op
;
1849 /* Only use new-style comparisons. */
1852 case INTRINSIC_EQ_OS
:
1856 case INTRINSIC_GE_OS
:
1860 case INTRINSIC_LE_OS
:
1864 case INTRINSIC_NE_OS
:
1868 case INTRINSIC_GT_OS
:
1872 case INTRINSIC_LT_OS
:
1888 changed
= optimize_comparison (e
, op
);
1891 /* Look at array constructors. */
1892 case INTRINSIC_PLUS
:
1893 case INTRINSIC_MINUS
:
1894 case INTRINSIC_TIMES
:
1895 case INTRINSIC_DIVIDE
:
1896 return combine_array_constructor (e
) || changed
;
1898 case INTRINSIC_POWER
:
1899 return optimize_power (e
);
1909 /* Return true if a constant string contains only blanks. */
1912 is_empty_string (gfc_expr
*e
)
1916 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1919 for (i
=0; i
< e
->value
.character
.length
; i
++)
1921 if (e
->value
.character
.string
[i
] != ' ')
1929 /* Insert a call to the intrinsic len_trim. Use a different name for
1930 the symbol tree so we don't run into trouble when the user has
1931 renamed len_trim for some reason. */
1934 get_len_trim_call (gfc_expr
*str
, int kind
)
1937 gfc_actual_arglist
*actual_arglist
, *next
;
1939 fcn
= gfc_get_expr ();
1940 fcn
->expr_type
= EXPR_FUNCTION
;
1941 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1942 actual_arglist
= gfc_get_actual_arglist ();
1943 actual_arglist
->expr
= str
;
1944 next
= gfc_get_actual_arglist ();
1945 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1946 actual_arglist
->next
= next
;
1948 fcn
->value
.function
.actual
= actual_arglist
;
1949 fcn
->where
= str
->where
;
1950 fcn
->ts
.type
= BT_INTEGER
;
1951 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1953 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1954 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1955 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1956 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1957 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1958 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1959 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1960 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1965 /* Optimize expressions for equality. */
1968 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1970 gfc_expr
*op1
, *op2
;
1974 gfc_actual_arglist
*firstarg
, *secondarg
;
1976 if (e
->expr_type
== EXPR_OP
)
1980 op1
= e
->value
.op
.op1
;
1981 op2
= e
->value
.op
.op2
;
1983 else if (e
->expr_type
== EXPR_FUNCTION
)
1985 /* One of the lexical comparison functions. */
1986 firstarg
= e
->value
.function
.actual
;
1987 secondarg
= firstarg
->next
;
1988 op1
= firstarg
->expr
;
1989 op2
= secondarg
->expr
;
1994 /* Strip off unneeded TRIM calls from string comparisons. */
1996 change
= remove_trim (op1
);
1998 if (remove_trim (op2
))
2001 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2002 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2003 handles them well). However, there are also cases that need a non-scalar
2004 argument. For example the any intrinsic. See PR 45380. */
2008 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2010 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2011 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2013 bool empty_op1
, empty_op2
;
2014 empty_op1
= is_empty_string (op1
);
2015 empty_op2
= is_empty_string (op2
);
2017 if (empty_op1
|| empty_op2
)
2023 /* This can only happen when an error for comparing
2024 characters of different kinds has already been issued. */
2025 if (empty_op1
&& empty_op2
)
2028 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2029 str
= empty_op1
? op2
: op1
;
2031 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2035 gfc_free_expr (op1
);
2037 gfc_free_expr (op2
);
2041 e
->value
.op
.op1
= fcn
;
2042 e
->value
.op
.op2
= zero
;
2047 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2049 if (flag_finite_math_only
2050 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2051 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2053 eq
= gfc_dep_compare_expr (op1
, op2
);
2056 /* Replace A // B < A // C with B < C, and A // B < C // B
2058 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2059 && op1
->expr_type
== EXPR_OP
2060 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2061 && op2
->expr_type
== EXPR_OP
2062 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2064 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2065 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2066 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2067 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2069 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2071 /* Watch out for 'A ' // x vs. 'A' // x. */
2073 if (op1_left
->expr_type
== EXPR_CONSTANT
2074 && op2_left
->expr_type
== EXPR_CONSTANT
2075 && op1_left
->value
.character
.length
2076 != op2_left
->value
.character
.length
)
2084 firstarg
->expr
= op1_right
;
2085 secondarg
->expr
= op2_right
;
2089 e
->value
.op
.op1
= op1_right
;
2090 e
->value
.op
.op2
= op2_right
;
2092 optimize_comparison (e
, op
);
2096 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2102 firstarg
->expr
= op1_left
;
2103 secondarg
->expr
= op2_left
;
2107 e
->value
.op
.op1
= op1_left
;
2108 e
->value
.op
.op2
= op2_left
;
2111 optimize_comparison (e
, op
);
2118 /* eq can only be -1, 0 or 1 at this point. */
2146 gfc_internal_error ("illegal OP in optimize_comparison");
2150 /* Replace the expression by a constant expression. The typespec
2151 and where remains the way it is. */
2154 e
->expr_type
= EXPR_CONSTANT
;
2155 e
->value
.logical
= result
;
2163 /* Optimize a trim function by replacing it with an equivalent substring
2164 involving a call to len_trim. This only works for expressions where
2165 variables are trimmed. Return true if anything was modified. */
2168 optimize_trim (gfc_expr
*e
)
2173 gfc_ref
**rr
= NULL
;
2175 /* Don't do this optimization within an argument list, because
2176 otherwise aliasing issues may occur. */
2178 if (count_arglist
!= 1)
2181 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2182 || e
->value
.function
.isym
== NULL
2183 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2186 a
= e
->value
.function
.actual
->expr
;
2188 if (a
->expr_type
!= EXPR_VARIABLE
)
2191 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2193 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2196 /* Follow all references to find the correct place to put the newly
2197 created reference. FIXME: Also handle substring references and
2198 array references. Array references cause strange regressions at
2203 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2205 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2210 strip_function_call (e
);
2215 /* Create the reference. */
2217 ref
= gfc_get_ref ();
2218 ref
->type
= REF_SUBSTRING
;
2220 /* Set the start of the reference. */
2222 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2224 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2226 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
2228 /* Set the end of the reference to the call to len_trim. */
2230 ref
->u
.ss
.end
= fcn
;
2231 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2236 /* Optimize minloc(b), where b is rank 1 array, into
2237 (/ minloc(b, dim=1) /), and similarly for maxloc,
2238 as the latter forms are expanded inline. */
2241 optimize_minmaxloc (gfc_expr
**e
)
2244 gfc_actual_arglist
*a
;
2248 || fn
->value
.function
.actual
== NULL
2249 || fn
->value
.function
.actual
->expr
== NULL
2250 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2253 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2254 (*e
)->shape
= fn
->shape
;
2257 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2259 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2260 strcpy (name
, fn
->value
.function
.name
);
2261 p
= strstr (name
, "loc0");
2263 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2264 if (fn
->value
.function
.actual
->next
)
2266 a
= fn
->value
.function
.actual
->next
;
2267 gcc_assert (a
->expr
== NULL
);
2271 a
= gfc_get_actual_arglist ();
2272 fn
->value
.function
.actual
->next
= a
;
2274 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2276 mpz_set_ui (a
->expr
->value
.integer
, 1);
2279 /* Callback function for code checking that we do not pass a DO variable to an
2280 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2283 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2284 void *data ATTRIBUTE_UNUSED
)
2288 gfc_formal_arglist
*f
;
2289 gfc_actual_arglist
*a
;
2296 /* If the doloop_list grew, we have to truncate it here. */
2298 if ((unsigned) doloop_level
< doloop_list
.length())
2299 doloop_list
.truncate (doloop_level
);
2306 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2311 loop
.branch_level
= if_level
+ select_level
;
2312 loop
.seen_goto
= false;
2313 doloop_list
.safe_push (loop
);
2316 /* If anything could transfer control away from a suspicious
2317 subscript, make sure to set seen_goto in the current DO loop
2322 case EXEC_ERROR_STOP
:
2328 if (co
->ext
.open
->err
)
2333 if (co
->ext
.close
->err
)
2337 case EXEC_BACKSPACE
:
2342 if (co
->ext
.filepos
->err
)
2347 if (co
->ext
.filepos
->err
)
2353 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2358 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2359 loop
.seen_goto
= true;
2364 if (co
->resolved_sym
== NULL
)
2367 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2369 /* Withot a formal arglist, there is only unknown INTENT,
2370 which we don't check for. */
2378 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2386 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2388 if (a
->expr
&& a
->expr
->symtree
2389 && a
->expr
->symtree
->n
.sym
== do_sym
)
2391 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2392 gfc_error_now ("Variable %qs at %L set to undefined "
2393 "value inside loop beginning at %L as "
2394 "INTENT(OUT) argument to subroutine %qs",
2395 do_sym
->name
, &a
->expr
->where
,
2396 &(doloop_list
[i
].c
->loc
),
2397 co
->symtree
->n
.sym
->name
);
2398 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2399 gfc_error_now ("Variable %qs at %L not definable inside "
2400 "loop beginning at %L as INTENT(INOUT) "
2401 "argument to subroutine %qs",
2402 do_sym
->name
, &a
->expr
->where
,
2403 &(doloop_list
[i
].c
->loc
),
2404 co
->symtree
->n
.sym
->name
);
2415 if (seen_goto
&& doloop_level
> 0)
2416 doloop_list
[doloop_level
-1].seen_goto
= true;
2421 /* Callback function to warn about different things within DO loops. */
2424 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2425 void *data ATTRIBUTE_UNUSED
)
2429 if (doloop_list
.length () == 0)
2432 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2435 last
= &doloop_list
.last();
2436 if (last
->seen_goto
&& !warn_do_subscript
)
2439 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2451 /* Callback function - if the expression is the variable in data->sym,
2452 replace it with a constant from data->val. */
2455 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2462 if (ex
->expr_type
!= EXPR_VARIABLE
)
2465 d
= (insert_index_t
*) data
;
2466 if (ex
->symtree
->n
.sym
!= d
->sym
)
2469 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2470 mpz_set (n
->value
.integer
, d
->val
);
2477 /* In the expression e, replace occurrences of the variable sym with
2478 val. If this results in a constant expression, return true and
2479 return the value in ret. Return false if the expression already
2480 is a constant. Caller has to clear ret in that case. */
2483 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2486 insert_index_t data
;
2489 if (e
->expr_type
== EXPR_CONSTANT
)
2492 n
= gfc_copy_expr (e
);
2494 mpz_init_set (data
.val
, val
);
2495 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2496 gfc_simplify_expr (n
, 0);
2498 if (n
->expr_type
== EXPR_CONSTANT
)
2501 mpz_init_set (ret
, n
->value
.integer
);
2506 mpz_clear (data
.val
);
2512 /* Check array subscripts for possible out-of-bounds accesses in DO
2513 loops with constant bounds. */
2516 do_subscript (gfc_expr
**e
)
2526 /* Constants are already checked. */
2527 if (v
->expr_type
== EXPR_CONSTANT
)
2530 /* Wrong warnings will be generated in an associate list. */
2534 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2536 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2539 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2542 mpz_t do_start
, do_step
, do_end
;
2543 bool have_do_start
, have_do_end
;
2544 bool error_not_proven
;
2551 /* If we are within a branch, or a goto or equivalent
2552 was seen in the DO loop before, then we cannot prove that
2553 this expression is actually evaluated. Don't do anything
2554 unless we want to see it all. */
2555 error_not_proven
= lp
->seen_goto
2556 || lp
->branch_level
< if_level
+ select_level
;
2558 if (error_not_proven
&& !warn_do_subscript
)
2561 if (error_not_proven
)
2562 warn
= OPT_Wdo_subscript
;
2566 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2567 if (do_sym
->ts
.type
!= BT_INTEGER
)
2570 /* If we do not know about the stepsize, the loop may be zero trip.
2571 Do not warn in this case. */
2573 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2574 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2578 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2580 have_do_start
= true;
2581 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2584 have_do_start
= false;
2587 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2590 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2593 have_do_end
= false;
2595 if (!have_do_start
&& !have_do_end
)
2598 /* May have to correct the end value if the step does not equal
2600 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2606 mpz_sub (diff
, do_end
, do_start
);
2607 mpz_tdiv_r (rem
, diff
, do_step
);
2608 mpz_sub (do_end
, do_end
, rem
);
2613 for (i
= 0; i
< ar
->dimen
; i
++)
2616 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2617 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2619 if (ar
->as
->lower
[i
]
2620 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2621 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2622 gfc_warning (warn
, "Array reference at %L out of bounds "
2623 "(%ld < %ld) in loop beginning at %L",
2624 &ar
->start
[i
]->where
, mpz_get_si (val
),
2625 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2626 &doloop_list
[j
].c
->loc
);
2628 if (ar
->as
->upper
[i
]
2629 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2630 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2631 gfc_warning (warn
, "Array reference at %L out of bounds "
2632 "(%ld > %ld) in loop beginning at %L",
2633 &ar
->start
[i
]->where
, mpz_get_si (val
),
2634 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2635 &doloop_list
[j
].c
->loc
);
2640 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2641 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2643 if (ar
->as
->lower
[i
]
2644 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2645 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2646 gfc_warning (warn
, "Array reference at %L out of bounds "
2647 "(%ld < %ld) in loop beginning at %L",
2648 &ar
->start
[i
]->where
, mpz_get_si (val
),
2649 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2650 &doloop_list
[j
].c
->loc
);
2652 if (ar
->as
->upper
[i
]
2653 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2654 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2655 gfc_warning (warn
, "Array reference at %L out of bounds "
2656 "(%ld > %ld) in loop beginning at %L",
2657 &ar
->start
[i
]->where
, mpz_get_si (val
),
2658 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2659 &doloop_list
[j
].c
->loc
);
2669 /* Function for functions checking that we do not pass a DO variable
2670 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2673 do_intent (gfc_expr
**e
)
2675 gfc_formal_arglist
*f
;
2676 gfc_actual_arglist
*a
;
2683 if (expr
->expr_type
!= EXPR_FUNCTION
)
2686 /* Intrinsic functions don't modify their arguments. */
2688 if (expr
->value
.function
.isym
)
2691 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2693 /* Without a formal arglist, there is only unknown INTENT,
2694 which we don't check for. */
2698 a
= expr
->value
.function
.actual
;
2702 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2709 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2711 if (a
->expr
&& a
->expr
->symtree
2712 && a
->expr
->symtree
->n
.sym
== do_sym
)
2714 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2715 gfc_error_now ("Variable %qs at %L set to undefined value "
2716 "inside loop beginning at %L as INTENT(OUT) "
2717 "argument to function %qs", do_sym
->name
,
2718 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2719 expr
->symtree
->n
.sym
->name
);
2720 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2721 gfc_error_now ("Variable %qs at %L not definable inside loop"
2722 " beginning at %L as INTENT(INOUT) argument to"
2723 " function %qs", do_sym
->name
,
2724 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2725 expr
->symtree
->n
.sym
->name
);
2736 doloop_warn (gfc_namespace
*ns
)
2738 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2741 /* This selction deals with inlining calls to MATMUL. */
2743 /* Replace calls to matmul outside of straight assignments with a temporary
2744 variable so that later inlining will work. */
2747 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2751 bool *found
= (bool *) data
;
2755 if (e
->expr_type
!= EXPR_FUNCTION
2756 || e
->value
.function
.isym
== NULL
2757 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2760 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2764 /* Check if this is already in the form c = matmul(a,b). */
2766 if ((*current_code
)->expr2
== e
)
2769 n
= create_var (e
, "matmul");
2771 /* If create_var is unable to create a variable (for example if
2772 -fno-realloc-lhs is in force with a variable that does not have bounds
2773 known at compile-time), just return. */
2783 /* Set current_code and associated variables so that matmul_to_var_expr can
2787 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2788 void *data ATTRIBUTE_UNUSED
)
2790 if (current_code
!= c
)
2793 inserted_block
= NULL
;
2794 changed_statement
= NULL
;
2801 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2802 for a and b if there is a dependency between the arguments and the
2803 result variable or if a or b are the result of calculations that cannot
2804 be handled by the inliner. */
2807 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2808 void *data ATTRIBUTE_UNUSED
)
2810 gfc_expr
*expr1
, *expr2
;
2812 gfc_actual_arglist
*a
, *b
;
2814 gfc_expr
*matrix_a
, *matrix_b
;
2815 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2819 if (co
->op
!= EXEC_ASSIGN
)
2822 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2826 /* This has some duplication with inline_matmul_assign. This
2827 is because the creation of temporary variables could still fail,
2828 and inline_matmul_assign still needs to be able to handle these
2833 if (expr2
->expr_type
!= EXPR_FUNCTION
2834 || expr2
->value
.function
.isym
== NULL
2835 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2839 a
= expr2
->value
.function
.actual
;
2840 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2841 if (matrix_a
!= NULL
)
2843 if (matrix_a
->expr_type
== EXPR_VARIABLE
2844 && (gfc_check_dependency (matrix_a
, expr1
, true)
2845 || has_dimen_vector_ref (matrix_a
)))
2853 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2854 if (matrix_b
!= NULL
)
2856 if (matrix_b
->expr_type
== EXPR_VARIABLE
2857 && (gfc_check_dependency (matrix_b
, expr1
, true)
2858 || has_dimen_vector_ref (matrix_b
)))
2864 if (!a_tmp
&& !b_tmp
)
2868 inserted_block
= NULL
;
2869 changed_statement
= NULL
;
2873 at
= create_var (a
->expr
,"mma");
2880 bt
= create_var (b
->expr
,"mmb");
2887 /* Auxiliary function to build and simplify an array inquiry function.
2888 dim is zero-based. */
2891 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2894 gfc_expr
*dim_arg
, *kind
;
2900 case GFC_ISYM_LBOUND
:
2901 name
= "_gfortran_lbound";
2904 case GFC_ISYM_UBOUND
:
2905 name
= "_gfortran_ubound";
2909 name
= "_gfortran_size";
2916 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2917 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2918 gfc_index_integer_kind
);
2920 ec
= gfc_copy_expr (e
);
2921 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2923 gfc_simplify_expr (fcn
, 0);
2927 /* Builds a logical expression. */
2930 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2935 ts
.type
= BT_LOGICAL
;
2936 ts
.kind
= gfc_default_logical_kind
;
2937 res
= gfc_get_expr ();
2938 res
->where
= e1
->where
;
2939 res
->expr_type
= EXPR_OP
;
2940 res
->value
.op
.op
= op
;
2941 res
->value
.op
.op1
= e1
;
2942 res
->value
.op
.op2
= e2
;
2949 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2950 compatible typespecs. */
2953 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2957 res
= gfc_get_expr ();
2959 res
->where
= e1
->where
;
2960 res
->expr_type
= EXPR_OP
;
2961 res
->value
.op
.op
= op
;
2962 res
->value
.op
.op1
= e1
;
2963 res
->value
.op
.op2
= e2
;
2964 gfc_simplify_expr (res
, 0);
2968 /* Generate the IF statement for a runtime check if we want to do inlining or
2969 not - putting in the code for both branches and putting it into the syntax
2970 tree is the caller's responsibility. For fixed array sizes, this should be
2971 removed by DCE. Only called for rank-two matrices A and B. */
2974 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2976 gfc_expr
*inline_limit
;
2977 gfc_code
*if_1
, *if_2
, *else_2
;
2978 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2982 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2984 /* Calculation is done in real to avoid integer overflow. */
2986 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2988 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2990 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2993 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2994 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2995 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2999 ts
.kind
= gfc_default_real_kind
;
3000 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3001 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3002 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3004 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3005 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3007 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3008 gfc_simplify_expr (cond
, 0);
3010 else_2
= XCNEW (gfc_code
);
3011 else_2
->op
= EXEC_IF
;
3012 else_2
->loc
= a
->where
;
3014 if_2
= XCNEW (gfc_code
);
3017 if_2
->loc
= a
->where
;
3018 if_2
->block
= else_2
;
3020 if_1
= XCNEW (gfc_code
);
3023 if_1
->loc
= a
->where
;
3029 /* Insert code to issue a runtime error if the expressions are not equal. */
3032 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3035 gfc_code
*if_1
, *if_2
;
3037 gfc_actual_arglist
*a1
, *a2
, *a3
;
3039 gcc_assert (e1
->where
.lb
);
3040 /* Build the call to runtime_error. */
3041 c
= XCNEW (gfc_code
);
3045 /* Get a null-terminated message string. */
3047 a1
= gfc_get_actual_arglist ();
3048 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3049 msg
, strlen(msg
)+1);
3052 /* Pass the value of the first expression. */
3053 a2
= gfc_get_actual_arglist ();
3054 a2
->expr
= gfc_copy_expr (e1
);
3057 /* Pass the value of the second expression. */
3058 a3
= gfc_get_actual_arglist ();
3059 a3
->expr
= gfc_copy_expr (e2
);
3062 gfc_check_fe_runtime_error (c
->ext
.actual
);
3063 gfc_resolve_fe_runtime_error (c
);
3065 if_2
= XCNEW (gfc_code
);
3067 if_2
->loc
= e1
->where
;
3070 if_1
= XCNEW (gfc_code
);
3073 if_1
->loc
= e1
->where
;
3075 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3076 gfc_simplify_expr (cond
, 0);
3082 /* Handle matrix reallocation. Caller is responsible to insert into
3085 For the two-dimensional case, build
3087 if (allocated(c)) then
3088 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3090 allocate (c(size(a,1), size(b,2)))
3093 allocate (c(size(a,1),size(b,2)))
3096 and for the other cases correspondingly.
3100 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3101 enum matrix_case m_case
)
3104 gfc_expr
*allocated
, *alloc_expr
;
3105 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3106 gfc_code
*else_alloc
;
3107 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3109 gfc_expr
*cond
, *ne1
, *ne2
;
3111 if (warn_realloc_lhs
)
3112 gfc_warning (OPT_Wrealloc_lhs
,
3113 "Code for reallocating the allocatable array at %L will "
3114 "be added", &c
->where
);
3116 alloc_expr
= gfc_copy_expr (c
);
3118 ar
= gfc_find_array_ref (alloc_expr
);
3119 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3121 /* c comes in as a full ref. Change it into a copy and make it into an
3122 element ref so it has the right form for for ALLOCATE. In the same
3123 switch statement, also generate the size comparison for the secod IF
3126 ar
->type
= AR_ELEMENT
;
3131 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3132 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3133 ne1
= build_logical_expr (INTRINSIC_NE
,
3134 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3135 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3136 ne2
= build_logical_expr (INTRINSIC_NE
,
3137 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3138 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3139 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3143 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3144 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3146 ne1
= build_logical_expr (INTRINSIC_NE
,
3147 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3148 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3149 ne2
= build_logical_expr (INTRINSIC_NE
,
3150 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3151 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3152 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3157 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3158 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3160 ne1
= build_logical_expr (INTRINSIC_NE
,
3161 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3162 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3163 ne2
= build_logical_expr (INTRINSIC_NE
,
3164 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3165 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3166 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3170 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3171 cond
= build_logical_expr (INTRINSIC_NE
,
3172 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3173 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3177 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3178 cond
= build_logical_expr (INTRINSIC_NE
,
3179 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3180 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3188 gfc_simplify_expr (cond
, 0);
3190 /* We need two identical allocate statements in two
3191 branches of the IF statement. */
3193 allocate1
= XCNEW (gfc_code
);
3194 allocate1
->op
= EXEC_ALLOCATE
;
3195 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3196 allocate1
->loc
= c
->where
;
3197 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3199 allocate_else
= XCNEW (gfc_code
);
3200 allocate_else
->op
= EXEC_ALLOCATE
;
3201 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3202 allocate_else
->loc
= c
->where
;
3203 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3205 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3206 "_gfortran_allocated", c
->where
,
3207 1, gfc_copy_expr (c
));
3209 deallocate
= XCNEW (gfc_code
);
3210 deallocate
->op
= EXEC_DEALLOCATE
;
3211 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3212 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3213 deallocate
->next
= allocate1
;
3214 deallocate
->loc
= c
->where
;
3216 if_size_2
= XCNEW (gfc_code
);
3217 if_size_2
->op
= EXEC_IF
;
3218 if_size_2
->expr1
= cond
;
3219 if_size_2
->loc
= c
->where
;
3220 if_size_2
->next
= deallocate
;
3222 if_size_1
= XCNEW (gfc_code
);
3223 if_size_1
->op
= EXEC_IF
;
3224 if_size_1
->block
= if_size_2
;
3225 if_size_1
->loc
= c
->where
;
3227 else_alloc
= XCNEW (gfc_code
);
3228 else_alloc
->op
= EXEC_IF
;
3229 else_alloc
->loc
= c
->where
;
3230 else_alloc
->next
= allocate_else
;
3232 if_alloc_2
= XCNEW (gfc_code
);
3233 if_alloc_2
->op
= EXEC_IF
;
3234 if_alloc_2
->expr1
= allocated
;
3235 if_alloc_2
->loc
= c
->where
;
3236 if_alloc_2
->next
= if_size_1
;
3237 if_alloc_2
->block
= else_alloc
;
3239 if_alloc_1
= XCNEW (gfc_code
);
3240 if_alloc_1
->op
= EXEC_IF
;
3241 if_alloc_1
->block
= if_alloc_2
;
3242 if_alloc_1
->loc
= c
->where
;
3247 /* Callback function for has_function_or_op. */
3250 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3251 void *data ATTRIBUTE_UNUSED
)
3256 return (*e
)->expr_type
== EXPR_FUNCTION
3257 || (*e
)->expr_type
== EXPR_OP
;
3260 /* Returns true if the expression contains a function. */
3263 has_function_or_op (gfc_expr
**e
)
3268 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3271 /* Freeze (assign to a temporary variable) a single expression. */
3274 freeze_expr (gfc_expr
**ep
)
3277 if (has_function_or_op (ep
))
3279 ne
= create_var (*ep
, "freeze");
3284 /* Go through an expression's references and assign them to temporary
3285 variables if they contain functions. This is usually done prior to
3286 front-end scalarization to avoid multiple invocations of functions. */
3289 freeze_references (gfc_expr
*e
)
3295 for (r
=e
->ref
; r
; r
=r
->next
)
3297 if (r
->type
== REF_SUBSTRING
)
3299 if (r
->u
.ss
.start
!= NULL
)
3300 freeze_expr (&r
->u
.ss
.start
);
3302 if (r
->u
.ss
.end
!= NULL
)
3303 freeze_expr (&r
->u
.ss
.end
);
3305 else if (r
->type
== REF_ARRAY
)
3314 for (i
=0; i
<ar
->dimen
; i
++)
3316 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3318 freeze_expr (&ar
->start
[i
]);
3319 freeze_expr (&ar
->end
[i
]);
3320 freeze_expr (&ar
->stride
[i
]);
3322 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3324 freeze_expr (&ar
->start
[i
]);
3330 for (i
=0; i
<ar
->dimen
; i
++)
3331 freeze_expr (&ar
->start
[i
]);
3341 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3344 convert_to_index_kind (gfc_expr
*e
)
3348 gcc_assert (e
!= NULL
);
3350 res
= gfc_copy_expr (e
);
3352 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3354 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3358 ts
.type
= BT_INTEGER
;
3359 ts
.kind
= gfc_index_integer_kind
;
3361 gfc_convert_type_warn (e
, &ts
, 2, 0);
3367 /* Function to create a DO loop including creation of the
3368 iteration variable. gfc_expr are copied.*/
3371 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3372 gfc_namespace
*ns
, char *vname
)
3375 char name
[GFC_MAX_SYMBOL_LEN
+1];
3376 gfc_symtree
*symtree
;
3381 /* Create an expression for the iteration variable. */
3383 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3385 sprintf (name
, "__var_%d_do", var_num
++);
3388 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3391 /* Create the loop variable. */
3393 symbol
= symtree
->n
.sym
;
3394 symbol
->ts
.type
= BT_INTEGER
;
3395 symbol
->ts
.kind
= gfc_index_integer_kind
;
3396 symbol
->attr
.flavor
= FL_VARIABLE
;
3397 symbol
->attr
.referenced
= 1;
3398 symbol
->attr
.dimension
= 0;
3399 symbol
->attr
.fe_temp
= 1;
3400 gfc_commit_symbol (symbol
);
3402 i
= gfc_get_expr ();
3403 i
->expr_type
= EXPR_VARIABLE
;
3407 i
->symtree
= symtree
;
3409 /* ... and the nested DO statements. */
3410 n
= XCNEW (gfc_code
);
3413 n
->ext
.iterator
= gfc_get_iterator ();
3414 n
->ext
.iterator
->var
= i
;
3415 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3416 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3418 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3420 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3423 n2
= XCNEW (gfc_code
);
3431 /* Get the upper bound of the DO loops for matmul along a dimension. This
3435 get_size_m1 (gfc_expr
*e
, int dimen
)
3440 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3442 res
= gfc_get_constant_expr (BT_INTEGER
,
3443 gfc_index_integer_kind
, &e
->where
);
3444 mpz_sub_ui (res
->value
.integer
, size
, 1);
3449 res
= get_operand (INTRINSIC_MINUS
,
3450 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3451 gfc_get_int_expr (gfc_index_integer_kind
,
3453 gfc_simplify_expr (res
, 0);
3459 /* Function to return a scalarized expression. It is assumed that indices are
3460 zero based to make generation of DO loops easier. A zero as index will
3461 access the first element along a dimension. Single element references will
3462 be skipped. A NULL as an expression will be replaced by a full reference.
3463 This assumes that the index loops have gfc_index_integer_kind, and that all
3464 references have been frozen. */
3467 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3476 e
= gfc_copy_expr(e_in
);
3480 ar
= gfc_find_array_ref (e
);
3482 /* We scalarize count_index variables, reducing the rank by count_index. */
3484 e
->rank
= rank
- count_index
;
3486 was_fullref
= ar
->type
== AR_FULL
;
3489 ar
->type
= AR_ELEMENT
;
3491 ar
->type
= AR_SECTION
;
3493 /* Loop over the indices. For each index, create the expression
3494 index * stride + lbound(e, dim). */
3497 for (i
=0; i
< ar
->dimen
; i
++)
3499 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3501 if (index
[i_index
] != NULL
)
3503 gfc_expr
*lbound
, *nindex
;
3506 loopvar
= gfc_copy_expr (index
[i_index
]);
3512 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3513 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3517 ts
.type
= BT_INTEGER
;
3518 ts
.kind
= gfc_index_integer_kind
;
3519 gfc_convert_type (tmp
, &ts
, 2);
3521 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3526 /* Calculate the lower bound of the expression. */
3529 lbound
= gfc_copy_expr (ar
->start
[i
]);
3530 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3534 ts
.type
= BT_INTEGER
;
3535 ts
.kind
= gfc_index_integer_kind
;
3536 gfc_convert_type (lbound
, &ts
, 2);
3545 lbound_e
= gfc_copy_expr (e_in
);
3547 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3548 if (ref
->type
== REF_ARRAY
3549 && (ref
->u
.ar
.type
== AR_FULL
3550 || ref
->u
.ar
.type
== AR_SECTION
))
3555 gfc_free_ref_list (ref
->next
);
3561 /* Look at full individual sections, like a(:). The first index
3562 is the lbound of a full ref. */
3568 for (j
= 0; j
< ar
->dimen
; j
++)
3570 gfc_free_expr (ar
->start
[j
]);
3571 ar
->start
[j
] = NULL
;
3572 gfc_free_expr (ar
->end
[j
]);
3574 gfc_free_expr (ar
->stride
[j
]);
3575 ar
->stride
[j
] = NULL
;
3578 /* We have to get rid of the shape, if there is one. Do
3579 so by freeing it and calling gfc_resolve to rebuild
3580 it, if necessary. */
3582 if (lbound_e
->shape
)
3583 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3585 lbound_e
->rank
= ar
->dimen
;
3586 gfc_resolve_expr (lbound_e
);
3588 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3590 gfc_free_expr (lbound_e
);
3593 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3595 gfc_free_expr (ar
->start
[i
]);
3596 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3598 gfc_free_expr (ar
->end
[i
]);
3600 gfc_free_expr (ar
->stride
[i
]);
3601 ar
->stride
[i
] = NULL
;
3602 gfc_simplify_expr (ar
->start
[i
], 0);
3604 else if (was_fullref
)
3606 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3615 /* Helper function to check for a dimen vector as subscript. */
3618 has_dimen_vector_ref (gfc_expr
*e
)
3623 ar
= gfc_find_array_ref (e
);
3625 if (ar
->type
== AR_FULL
)
3628 for (i
=0; i
<ar
->dimen
; i
++)
3629 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3635 /* If handed an expression of the form
3639 check if A can be handled by matmul and return if there is an uneven number
3640 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3641 otherwise. The caller has to check for the correct rank. */
3644 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3651 if (e
->expr_type
== EXPR_VARIABLE
)
3653 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3656 else if (e
->expr_type
== EXPR_FUNCTION
)
3658 if (e
->value
.function
.isym
== NULL
)
3661 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3663 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3664 *transpose
= !*transpose
;
3670 e
= e
->value
.function
.actual
->expr
;
3677 /* Inline assignments of the form c = matmul(a,b).
3678 Handle only the cases currently where b and c are rank-two arrays.
3680 This basically translates the code to
3686 do k=0, size(a, 2)-1
3687 do i=0, size(a, 1)-1
3688 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3689 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3690 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3691 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3700 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3701 void *data ATTRIBUTE_UNUSED
)
3704 gfc_expr
*expr1
, *expr2
;
3705 gfc_expr
*matrix_a
, *matrix_b
;
3706 gfc_actual_arglist
*a
, *b
;
3707 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3709 gfc_expr
*u1
, *u2
, *u3
;
3711 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3713 gfc_expr
*var_1
, *var_2
, *var_3
;
3716 gfc_intrinsic_op op_times
, op_plus
;
3717 enum matrix_case m_case
;
3719 gfc_code
*if_limit
= NULL
;
3720 gfc_code
**next_code_point
;
3721 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3723 if (co
->op
!= EXEC_ASSIGN
)
3729 /* The BLOCKS generated for the temporary variables and FORALL don't
3731 if (forall_level
> 0)
3734 /* For now don't do anything in OpenMP workshare, it confuses
3735 its translation, which expects only the allowed statements in there.
3736 We should figure out how to parallelize this eventually. */
3737 if (in_omp_workshare
)
3742 if (expr2
->expr_type
!= EXPR_FUNCTION
3743 || expr2
->value
.function
.isym
== NULL
3744 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3748 inserted_block
= NULL
;
3749 changed_statement
= NULL
;
3751 a
= expr2
->value
.function
.actual
;
3752 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3753 if (matrix_a
== NULL
)
3757 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3758 if (matrix_b
== NULL
)
3761 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3762 || has_dimen_vector_ref (matrix_b
))
3765 /* We do not handle data dependencies yet. */
3766 if (gfc_check_dependency (expr1
, matrix_a
, true)
3767 || gfc_check_dependency (expr1
, matrix_b
, true))
3771 if (matrix_a
->rank
== 2)
3775 if (matrix_b
->rank
== 2 && !transpose_b
)
3780 if (matrix_b
->rank
== 1)
3782 else /* matrix_b->rank == 2 */
3791 else /* matrix_a->rank == 1 */
3793 if (matrix_b
->rank
== 2)
3803 ns
= insert_block ();
3805 /* Assign the type of the zero expression for initializing the resulting
3806 array, and the expression (+ and * for real, integer and complex;
3807 .and. and .or for logical. */
3809 switch(expr1
->ts
.type
)
3812 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3813 op_times
= INTRINSIC_TIMES
;
3814 op_plus
= INTRINSIC_PLUS
;
3818 op_times
= INTRINSIC_AND
;
3819 op_plus
= INTRINSIC_OR
;
3820 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3824 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3826 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3827 op_times
= INTRINSIC_TIMES
;
3828 op_plus
= INTRINSIC_PLUS
;
3832 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3834 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3835 op_times
= INTRINSIC_TIMES
;
3836 op_plus
= INTRINSIC_PLUS
;
3844 current_code
= &ns
->code
;
3846 /* Freeze the references, keeping track of how many temporary variables were
3849 freeze_references (matrix_a
);
3850 freeze_references (matrix_b
);
3851 freeze_references (expr1
);
3854 next_code_point
= current_code
;
3857 next_code_point
= &ns
->code
;
3858 for (i
=0; i
<n_vars
; i
++)
3859 next_code_point
= &(*next_code_point
)->next
;
3862 /* Take care of the inline flag. If the limit check evaluates to a
3863 constant, dead code elimination will eliminate the unneeded branch. */
3865 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3867 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3869 /* Insert the original statement into the else branch. */
3870 if_limit
->block
->block
->next
= co
;
3873 /* ... and the new ones go into the original one. */
3874 *next_code_point
= if_limit
;
3875 next_code_point
= &if_limit
->block
->next
;
3878 assign_zero
= XCNEW (gfc_code
);
3879 assign_zero
->op
= EXEC_ASSIGN
;
3880 assign_zero
->loc
= co
->loc
;
3881 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3882 assign_zero
->expr2
= zero_e
;
3884 /* Handle the reallocation, if needed. */
3885 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3887 gfc_code
*lhs_alloc
;
3889 /* Only need to check a single dimension for the A2B2 case for
3890 bounds checking, the rest will be allocated. Also check this
3893 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3898 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3899 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3900 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3901 "in MATMUL intrinsic: Is %ld, should be %ld");
3902 *next_code_point
= test
;
3903 next_code_point
= &test
->next
;
3907 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3909 *next_code_point
= lhs_alloc
;
3910 next_code_point
= &lhs_alloc
->next
;
3913 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3916 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3918 if (m_case
== A2B2
|| m_case
== A2B1
)
3920 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3921 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3922 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3923 "in MATMUL intrinsic: Is %ld, should be %ld");
3924 *next_code_point
= test
;
3925 next_code_point
= &test
->next
;
3927 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3928 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3931 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3932 "MATMUL intrinsic for dimension 1: "
3933 "is %ld, should be %ld");
3934 else if (m_case
== A2B1
)
3935 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3936 "MATMUL intrinsic: "
3937 "is %ld, should be %ld");
3940 *next_code_point
= test
;
3941 next_code_point
= &test
->next
;
3943 else if (m_case
== A1B2
)
3945 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3946 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3947 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3948 "in MATMUL intrinsic: Is %ld, should be %ld");
3949 *next_code_point
= test
;
3950 next_code_point
= &test
->next
;
3952 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3953 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3955 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3956 "MATMUL intrinsic: "
3957 "is %ld, should be %ld");
3959 *next_code_point
= test
;
3960 next_code_point
= &test
->next
;
3965 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3966 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3967 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3968 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3970 *next_code_point
= test
;
3971 next_code_point
= &test
->next
;
3974 if (m_case
== A2B2T
)
3976 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3977 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3978 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3979 "MATMUL intrinsic for dimension 1: "
3980 "is %ld, should be %ld");
3982 *next_code_point
= test
;
3983 next_code_point
= &test
->next
;
3985 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3986 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3987 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3988 "MATMUL intrinsic for dimension 2: "
3989 "is %ld, should be %ld");
3990 *next_code_point
= test
;
3991 next_code_point
= &test
->next
;
3993 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3994 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3996 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3997 "MATMUL intrnisic for dimension 2: "
3998 "is %ld, should be %ld");
3999 *next_code_point
= test
;
4000 next_code_point
= &test
->next
;
4004 if (m_case
== A2TB2
)
4006 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4007 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4009 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
4010 "MATMUL intrinsic for dimension 1: "
4011 "is %ld, should be %ld");
4013 *next_code_point
= test
;
4014 next_code_point
= &test
->next
;
4016 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4017 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4018 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4019 "MATMUL intrinsic for dimension 2: "
4020 "is %ld, should be %ld");
4021 *next_code_point
= test
;
4022 next_code_point
= &test
->next
;
4024 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4025 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4027 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
4028 "MATMUL intrnisic for dimension 2: "
4029 "is %ld, should be %ld");
4030 *next_code_point
= test
;
4031 next_code_point
= &test
->next
;
4036 *next_code_point
= assign_zero
;
4038 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4040 assign_matmul
= XCNEW (gfc_code
);
4041 assign_matmul
->op
= EXEC_ASSIGN
;
4042 assign_matmul
->loc
= co
->loc
;
4044 /* Get the bounds for the loops, create them and create the scalarized
4050 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4052 u1
= get_size_m1 (matrix_b
, 2);
4053 u2
= get_size_m1 (matrix_a
, 2);
4054 u3
= get_size_m1 (matrix_a
, 1);
4056 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4057 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4058 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4060 do_1
->block
->next
= do_2
;
4061 do_2
->block
->next
= do_3
;
4062 do_3
->block
->next
= assign_matmul
;
4064 var_1
= do_1
->ext
.iterator
->var
;
4065 var_2
= do_2
->ext
.iterator
->var
;
4066 var_3
= do_3
->ext
.iterator
->var
;
4070 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4074 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4078 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4083 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4085 u1
= get_size_m1 (matrix_b
, 1);
4086 u2
= get_size_m1 (matrix_a
, 2);
4087 u3
= get_size_m1 (matrix_a
, 1);
4089 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4090 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4091 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4093 do_1
->block
->next
= do_2
;
4094 do_2
->block
->next
= do_3
;
4095 do_3
->block
->next
= assign_matmul
;
4097 var_1
= do_1
->ext
.iterator
->var
;
4098 var_2
= do_2
->ext
.iterator
->var
;
4099 var_3
= do_3
->ext
.iterator
->var
;
4103 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4107 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4111 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4116 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4118 u1
= get_size_m1 (matrix_a
, 2);
4119 u2
= get_size_m1 (matrix_b
, 2);
4120 u3
= get_size_m1 (matrix_a
, 1);
4122 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4123 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4124 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4126 do_1
->block
->next
= do_2
;
4127 do_2
->block
->next
= do_3
;
4128 do_3
->block
->next
= assign_matmul
;
4130 var_1
= do_1
->ext
.iterator
->var
;
4131 var_2
= do_2
->ext
.iterator
->var
;
4132 var_3
= do_3
->ext
.iterator
->var
;
4136 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4140 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4144 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4149 u1
= get_size_m1 (matrix_b
, 1);
4150 u2
= get_size_m1 (matrix_a
, 1);
4152 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4153 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4155 do_1
->block
->next
= do_2
;
4156 do_2
->block
->next
= assign_matmul
;
4158 var_1
= do_1
->ext
.iterator
->var
;
4159 var_2
= do_2
->ext
.iterator
->var
;
4162 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4166 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4169 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4174 u1
= get_size_m1 (matrix_b
, 2);
4175 u2
= get_size_m1 (matrix_a
, 1);
4177 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4178 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4180 do_1
->block
->next
= do_2
;
4181 do_2
->block
->next
= assign_matmul
;
4183 var_1
= do_1
->ext
.iterator
->var
;
4184 var_2
= do_2
->ext
.iterator
->var
;
4187 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4190 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4194 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4202 /* Build the conjg call around the variables. Set the typespec manually
4203 because gfc_build_intrinsic_call sometimes gets this wrong. */
4208 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4209 matrix_a
->where
, 1, ascalar
);
4217 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4218 matrix_b
->where
, 1, bscalar
);
4221 /* First loop comes after the zero assignment. */
4222 assign_zero
->next
= do_1
;
4224 /* Build the assignment expression in the loop. */
4225 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4227 mult
= get_operand (op_times
, ascalar
, bscalar
);
4228 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4230 /* If we don't want to keep the original statement around in
4231 the else branch, we can free it. */
4233 if (if_limit
== NULL
)
4234 gfc_free_statements(co
);
4238 gfc_free_expr (zero
);
4244 /* Code for index interchange for loops which are grouped together in DO
4245 CONCURRENT or FORALL statements. This is currently only applied if the
4246 iterations are grouped together in a single statement.
4248 For this transformation, it is assumed that memory access in strides is
4249 expensive, and that loops which access later indices (which access memory
4250 in bigger strides) should be moved to the first loops.
4252 For this, a loop over all the statements is executed, counting the times
4253 that the loop iteration values are accessed in each index. The loop
4254 indices are then sorted to minimize access to later indices from inner
4257 /* Type for holding index information. */
4261 gfc_forall_iterator
*fa
;
4263 int n
[GFC_MAX_DIMENSIONS
];
4266 /* Callback function to determine if an expression is the
4267 corresponding variable. */
4270 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4272 gfc_expr
*expr
= *e
;
4275 if (expr
->expr_type
!= EXPR_VARIABLE
)
4278 sym
= (gfc_symbol
*) data
;
4279 return sym
== expr
->symtree
->n
.sym
;
4282 /* Callback function to calculate the cost of a certain index. */
4285 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4295 if (expr
->expr_type
!= EXPR_VARIABLE
)
4299 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4301 if (ref
->type
== REF_ARRAY
)
4307 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4310 ind
= (ind_type
*) data
;
4311 for (i
= 0; i
< ar
->dimen
; i
++)
4313 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4315 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4322 /* Callback function for qsort, to sort the loop indices. */
4325 loop_comp (const void *e1
, const void *e2
)
4327 const ind_type
*i1
= (const ind_type
*) e1
;
4328 const ind_type
*i2
= (const ind_type
*) e2
;
4331 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4333 if (i1
->n
[i
] != i2
->n
[i
])
4334 return i1
->n
[i
] - i2
->n
[i
];
4336 /* All other things being equal, let's not change the ordering. */
4337 return i2
->num
- i1
->num
;
4340 /* Main function to do the index interchange. */
4343 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4344 void *data ATTRIBUTE_UNUSED
)
4349 gfc_forall_iterator
*fa
;
4353 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4357 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4360 /* Nothing to reorder. */
4364 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4367 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4369 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4371 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4376 ind
[n_iter
].sym
= NULL
;
4377 ind
[n_iter
].fa
= NULL
;
4379 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4380 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4382 /* Do the actual index interchange. */
4383 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4384 for (i
=1; i
<n_iter
; i
++)
4386 fa
->next
= ind
[i
].fa
;
4391 if (flag_warn_frontend_loop_interchange
)
4393 for (i
=1; i
<n_iter
; i
++)
4395 if (ind
[i
-1].num
> ind
[i
].num
)
4397 gfc_warning (OPT_Wfrontend_loop_interchange
,
4398 "Interchanging loops at %L", &co
->loc
);
4407 #define WALK_SUBEXPR(NODE) \
4410 result = gfc_expr_walker (&(NODE), exprfn, data); \
4415 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4417 /* Walk expression *E, calling EXPRFN on each expression in it. */
4420 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4424 int walk_subtrees
= 1;
4425 gfc_actual_arglist
*a
;
4429 int result
= exprfn (e
, &walk_subtrees
, data
);
4433 switch ((*e
)->expr_type
)
4436 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4437 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4440 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4441 WALK_SUBEXPR (a
->expr
);
4445 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4446 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4447 WALK_SUBEXPR (a
->expr
);
4450 case EXPR_STRUCTURE
:
4452 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4453 c
= gfc_constructor_next (c
))
4455 if (c
->iterator
== NULL
)
4456 WALK_SUBEXPR (c
->expr
);
4460 WALK_SUBEXPR (c
->expr
);
4462 WALK_SUBEXPR (c
->iterator
->var
);
4463 WALK_SUBEXPR (c
->iterator
->start
);
4464 WALK_SUBEXPR (c
->iterator
->end
);
4465 WALK_SUBEXPR (c
->iterator
->step
);
4469 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4472 /* Fall through to the variable case in order to walk the
4476 case EXPR_SUBSTRING
:
4478 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4487 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4489 for (i
=0; i
< ar
->dimen
; i
++)
4491 WALK_SUBEXPR (ar
->start
[i
]);
4492 WALK_SUBEXPR (ar
->end
[i
]);
4493 WALK_SUBEXPR (ar
->stride
[i
]);
4500 WALK_SUBEXPR (r
->u
.ss
.start
);
4501 WALK_SUBEXPR (r
->u
.ss
.end
);
4517 #define WALK_SUBCODE(NODE) \
4520 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4526 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4527 on each expression in it. If any of the hooks returns non-zero, that
4528 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4529 no subcodes or subexpressions are traversed. */
4532 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4535 for (; *c
; c
= &(*c
)->next
)
4537 int walk_subtrees
= 1;
4538 int result
= codefn (c
, &walk_subtrees
, data
);
4545 gfc_actual_arglist
*a
;
4547 gfc_association_list
*alist
;
4548 bool saved_in_omp_workshare
;
4549 bool saved_in_where
;
4551 /* There might be statement insertions before the current code,
4552 which must not affect the expression walker. */
4555 saved_in_omp_workshare
= in_omp_workshare
;
4556 saved_in_where
= in_where
;
4562 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4563 if (co
->ext
.block
.assoc
)
4565 bool saved_in_assoc_list
= in_assoc_list
;
4567 in_assoc_list
= true;
4568 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4569 WALK_SUBEXPR (alist
->target
);
4571 in_assoc_list
= saved_in_assoc_list
;
4578 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4579 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4580 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4581 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4593 case EXEC_ASSIGN_CALL
:
4594 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4595 WALK_SUBEXPR (a
->expr
);
4599 WALK_SUBEXPR (co
->expr1
);
4600 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4601 WALK_SUBEXPR (a
->expr
);
4605 WALK_SUBEXPR (co
->expr1
);
4607 for (b
= co
->block
; b
; b
= b
->block
)
4610 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4612 WALK_SUBEXPR (cp
->low
);
4613 WALK_SUBEXPR (cp
->high
);
4615 WALK_SUBCODE (b
->next
);
4620 case EXEC_DEALLOCATE
:
4623 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4624 WALK_SUBEXPR (a
->expr
);
4629 case EXEC_DO_CONCURRENT
:
4631 gfc_forall_iterator
*fa
;
4632 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4634 WALK_SUBEXPR (fa
->var
);
4635 WALK_SUBEXPR (fa
->start
);
4636 WALK_SUBEXPR (fa
->end
);
4637 WALK_SUBEXPR (fa
->stride
);
4639 if (co
->op
== EXEC_FORALL
)
4645 WALK_SUBEXPR (co
->ext
.open
->unit
);
4646 WALK_SUBEXPR (co
->ext
.open
->file
);
4647 WALK_SUBEXPR (co
->ext
.open
->status
);
4648 WALK_SUBEXPR (co
->ext
.open
->access
);
4649 WALK_SUBEXPR (co
->ext
.open
->form
);
4650 WALK_SUBEXPR (co
->ext
.open
->recl
);
4651 WALK_SUBEXPR (co
->ext
.open
->blank
);
4652 WALK_SUBEXPR (co
->ext
.open
->position
);
4653 WALK_SUBEXPR (co
->ext
.open
->action
);
4654 WALK_SUBEXPR (co
->ext
.open
->delim
);
4655 WALK_SUBEXPR (co
->ext
.open
->pad
);
4656 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4657 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4658 WALK_SUBEXPR (co
->ext
.open
->convert
);
4659 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4660 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4661 WALK_SUBEXPR (co
->ext
.open
->round
);
4662 WALK_SUBEXPR (co
->ext
.open
->sign
);
4663 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4664 WALK_SUBEXPR (co
->ext
.open
->id
);
4665 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4666 WALK_SUBEXPR (co
->ext
.open
->share
);
4667 WALK_SUBEXPR (co
->ext
.open
->cc
);
4671 WALK_SUBEXPR (co
->ext
.close
->unit
);
4672 WALK_SUBEXPR (co
->ext
.close
->status
);
4673 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4674 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4677 case EXEC_BACKSPACE
:
4681 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4682 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4683 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4687 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4688 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4689 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4690 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4691 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4692 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4693 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4694 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4695 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4696 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4697 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4698 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4699 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4700 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4701 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4702 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4703 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4704 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4705 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4706 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4707 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4708 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4709 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4710 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4711 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4712 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4713 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4714 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4715 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4716 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4717 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4718 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4719 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4720 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4721 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4722 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4726 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4727 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4728 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4729 WALK_SUBEXPR (co
->ext
.wait
->id
);
4734 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4735 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4736 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4737 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4738 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4739 WALK_SUBEXPR (co
->ext
.dt
->size
);
4740 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4741 WALK_SUBEXPR (co
->ext
.dt
->id
);
4742 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4743 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4744 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4745 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4746 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4747 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4748 WALK_SUBEXPR (co
->ext
.dt
->round
);
4749 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4750 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4753 case EXEC_OMP_PARALLEL
:
4754 case EXEC_OMP_PARALLEL_DO
:
4755 case EXEC_OMP_PARALLEL_DO_SIMD
:
4756 case EXEC_OMP_PARALLEL_SECTIONS
:
4758 in_omp_workshare
= false;
4760 /* This goto serves as a shortcut to avoid code
4761 duplication or a larger if or switch statement. */
4762 goto check_omp_clauses
;
4764 case EXEC_OMP_WORKSHARE
:
4765 case EXEC_OMP_PARALLEL_WORKSHARE
:
4767 in_omp_workshare
= true;
4771 case EXEC_OMP_CRITICAL
:
4772 case EXEC_OMP_DISTRIBUTE
:
4773 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4774 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4775 case EXEC_OMP_DISTRIBUTE_SIMD
:
4777 case EXEC_OMP_DO_SIMD
:
4778 case EXEC_OMP_ORDERED
:
4779 case EXEC_OMP_SECTIONS
:
4780 case EXEC_OMP_SINGLE
:
4781 case EXEC_OMP_END_SINGLE
:
4783 case EXEC_OMP_TASKLOOP
:
4784 case EXEC_OMP_TASKLOOP_SIMD
:
4785 case EXEC_OMP_TARGET
:
4786 case EXEC_OMP_TARGET_DATA
:
4787 case EXEC_OMP_TARGET_ENTER_DATA
:
4788 case EXEC_OMP_TARGET_EXIT_DATA
:
4789 case EXEC_OMP_TARGET_PARALLEL
:
4790 case EXEC_OMP_TARGET_PARALLEL_DO
:
4791 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4792 case EXEC_OMP_TARGET_SIMD
:
4793 case EXEC_OMP_TARGET_TEAMS
:
4794 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4795 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4796 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4797 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4798 case EXEC_OMP_TARGET_UPDATE
:
4800 case EXEC_OMP_TEAMS
:
4801 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4802 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4803 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4804 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4806 /* Come to this label only from the
4807 EXEC_OMP_PARALLEL_* cases above. */
4811 if (co
->ext
.omp_clauses
)
4813 gfc_omp_namelist
*n
;
4814 static int list_types
[]
4815 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4816 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4818 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4819 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4820 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4821 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4822 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4823 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4824 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4825 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4826 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4827 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4828 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4829 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4830 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4831 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4832 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4833 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4835 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4837 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4839 WALK_SUBEXPR (n
->expr
);
4846 WALK_SUBEXPR (co
->expr1
);
4847 WALK_SUBEXPR (co
->expr2
);
4848 WALK_SUBEXPR (co
->expr3
);
4849 WALK_SUBEXPR (co
->expr4
);
4850 for (b
= co
->block
; b
; b
= b
->block
)
4852 WALK_SUBEXPR (b
->expr1
);
4853 WALK_SUBEXPR (b
->expr2
);
4854 WALK_SUBCODE (b
->next
);
4857 if (co
->op
== EXEC_FORALL
)
4860 if (co
->op
== EXEC_DO
)
4863 if (co
->op
== EXEC_IF
)
4866 if (co
->op
== EXEC_SELECT
)
4869 in_omp_workshare
= saved_in_omp_workshare
;
4870 in_where
= saved_in_where
;