1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2018 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static 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 /* Creation of an array of unknown size requires realloc on assignment.
724 If that is not possible, just return NULL. */
725 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
728 ns
= insert_block ();
731 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
733 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
735 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
738 symbol
= symtree
->n
.sym
;
743 symbol
->as
= gfc_get_array_spec ();
744 symbol
->as
->rank
= e
->rank
;
746 if (e
->shape
== NULL
)
748 /* We don't know the shape at compile time, so we use an
750 symbol
->as
->type
= AS_DEFERRED
;
751 symbol
->attr
.allocatable
= 1;
755 symbol
->as
->type
= AS_EXPLICIT
;
756 /* Copy the shape. */
757 for (i
=0; i
<e
->rank
; i
++)
761 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
763 mpz_set_si (p
->value
.integer
, 1);
764 symbol
->as
->lower
[i
] = p
;
766 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
768 mpz_set (q
->value
.integer
, e
->shape
[i
]);
769 symbol
->as
->upper
[i
] = q
;
775 if (e
->ts
.type
== BT_CHARACTER
)
779 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
780 length
= constant_string_length (e
);
782 symbol
->ts
.u
.cl
->length
= length
;
785 symbol
->attr
.allocatable
= 1;
786 symbol
->ts
.u
.cl
->length
= NULL
;
787 symbol
->ts
.deferred
= 1;
792 symbol
->attr
.flavor
= FL_VARIABLE
;
793 symbol
->attr
.referenced
= 1;
794 symbol
->attr
.dimension
= e
->rank
> 0;
795 symbol
->attr
.fe_temp
= 1;
796 gfc_commit_symbol (symbol
);
798 result
= gfc_get_expr ();
799 result
->expr_type
= EXPR_VARIABLE
;
800 result
->ts
= symbol
->ts
;
801 result
->ts
.deferred
= deferred
;
802 result
->rank
= e
->rank
;
803 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
804 result
->symtree
= symtree
;
805 result
->where
= e
->where
;
808 result
->ref
= gfc_get_ref ();
809 result
->ref
->type
= REF_ARRAY
;
810 result
->ref
->u
.ar
.type
= AR_FULL
;
811 result
->ref
->u
.ar
.where
= e
->where
;
812 result
->ref
->u
.ar
.dimen
= e
->rank
;
813 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
814 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
815 if (warn_array_temporaries
)
816 gfc_warning (OPT_Warray_temporaries
,
817 "Creating array temporary at %L", &(e
->where
));
820 /* Generate the new assignment. */
821 n
= XCNEW (gfc_code
);
823 n
->loc
= (*current_code
)->loc
;
824 n
->next
= *changed_statement
;
825 n
->expr1
= gfc_copy_expr (result
);
827 *changed_statement
= n
;
833 /* Warn about function elimination. */
836 do_warn_function_elimination (gfc_expr
*e
)
838 if (e
->expr_type
!= EXPR_FUNCTION
)
840 if (e
->value
.function
.esym
)
841 gfc_warning (OPT_Wfunction_elimination
,
842 "Removing call to function %qs at %L",
843 e
->value
.function
.esym
->name
, &(e
->where
));
844 else if (e
->value
.function
.isym
)
845 gfc_warning (OPT_Wfunction_elimination
,
846 "Removing call to function %qs at %L",
847 e
->value
.function
.isym
->name
, &(e
->where
));
849 /* Callback function for the code walker for doing common function
850 elimination. This builds up the list of functions in the expression
851 and goes through them to detect duplicates, which it then replaces
855 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
856 void *data ATTRIBUTE_UNUSED
)
862 /* Don't do this optimization within OMP workshare or ASSOC lists. */
864 if (in_omp_workshare
|| in_assoc_list
)
870 expr_array
.release ();
872 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
874 /* Walk through all the functions. */
876 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
878 /* Skip if the function has been replaced by a variable already. */
879 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
886 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
889 newvar
= create_var (*ei
, "fcn");
891 if (warn_function_elimination
)
892 do_warn_function_elimination (*ej
);
895 *ej
= gfc_copy_expr (newvar
);
902 /* We did all the necessary walking in this function. */
907 /* Callback function for common function elimination, called from
908 gfc_code_walker. This keeps track of the current code, in order
909 to insert statements as needed. */
912 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
915 inserted_block
= NULL
;
916 changed_statement
= NULL
;
918 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
919 and allocation on assigment are prohibited inside WHERE, and finally
920 masking an expression would lead to wrong-code when replacing
923 b = sum(foo(a) + foo(a))
934 if ((*c
)->op
== EXEC_WHERE
)
944 /* Dummy function for expression call back, for use when we
945 really don't want to do any walking. */
948 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
949 void *data ATTRIBUTE_UNUSED
)
955 /* Dummy function for code callback, for use when we really
956 don't want to do anything. */
958 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
959 int *walk_subtrees ATTRIBUTE_UNUSED
,
960 void *data ATTRIBUTE_UNUSED
)
965 /* Code callback function for converting
972 This is because common function elimination would otherwise place the
973 temporary variables outside the loop. */
976 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
977 void *data ATTRIBUTE_UNUSED
)
980 gfc_code
*c_if1
, *c_if2
, *c_exit
;
982 gfc_expr
*e_not
, *e_cond
;
984 if (co
->op
!= EXEC_DO_WHILE
)
987 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
992 /* Generate the condition of the if statement, which is .not. the original
994 e_not
= gfc_get_expr ();
995 e_not
->ts
= e_cond
->ts
;
996 e_not
->where
= e_cond
->where
;
997 e_not
->expr_type
= EXPR_OP
;
998 e_not
->value
.op
.op
= INTRINSIC_NOT
;
999 e_not
->value
.op
.op1
= e_cond
;
1001 /* Generate the EXIT statement. */
1002 c_exit
= XCNEW (gfc_code
);
1003 c_exit
->op
= EXEC_EXIT
;
1004 c_exit
->ext
.which_construct
= co
;
1005 c_exit
->loc
= co
->loc
;
1007 /* Generate the IF statement. */
1008 c_if2
= XCNEW (gfc_code
);
1009 c_if2
->op
= EXEC_IF
;
1010 c_if2
->expr1
= e_not
;
1011 c_if2
->next
= c_exit
;
1012 c_if2
->loc
= co
->loc
;
1014 /* ... plus the one to chain it to. */
1015 c_if1
= XCNEW (gfc_code
);
1016 c_if1
->op
= EXEC_IF
;
1017 c_if1
->block
= c_if2
;
1018 c_if1
->loc
= co
->loc
;
1020 /* Make the DO WHILE loop into a DO block by replacing the condition
1021 with a true constant. */
1022 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1024 /* Hang the generated if statement into the loop body. */
1026 loopblock
= co
->block
->next
;
1027 co
->block
->next
= c_if1
;
1028 c_if1
->next
= loopblock
;
1033 /* Code callback function for converting
1046 because otherwise common function elimination would place the BLOCKs
1047 into the wrong place. */
1050 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1051 void *data ATTRIBUTE_UNUSED
)
1054 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1056 if (co
->op
!= EXEC_IF
)
1059 /* This loop starts out with the first ELSE statement. */
1060 else_stmt
= co
->block
->block
;
1062 while (else_stmt
!= NULL
)
1064 gfc_code
*next_else
;
1066 /* If there is no condition, we're done. */
1067 if (else_stmt
->expr1
== NULL
)
1070 next_else
= else_stmt
->block
;
1072 /* Generate the new IF statement. */
1073 c_if2
= XCNEW (gfc_code
);
1074 c_if2
->op
= EXEC_IF
;
1075 c_if2
->expr1
= else_stmt
->expr1
;
1076 c_if2
->next
= else_stmt
->next
;
1077 c_if2
->loc
= else_stmt
->loc
;
1078 c_if2
->block
= next_else
;
1080 /* ... plus the one to chain it to. */
1081 c_if1
= XCNEW (gfc_code
);
1082 c_if1
->op
= EXEC_IF
;
1083 c_if1
->block
= c_if2
;
1084 c_if1
->loc
= else_stmt
->loc
;
1086 /* Insert the new IF after the ELSE. */
1087 else_stmt
->expr1
= NULL
;
1088 else_stmt
->next
= c_if1
;
1089 else_stmt
->block
= NULL
;
1091 else_stmt
= next_else
;
1093 /* Don't walk subtrees. */
1099 struct do_stack
*prev
;
1104 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1105 optimize by replacing do loops with their analog array slices. For
1108 write (*,*) (a(i), i=1,4)
1112 write (*,*) a(1:4:1) . */
1115 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1118 gfc_expr
*new_e
, *expr
, *start
;
1120 struct do_stack ds_push
;
1121 int i
, future_rank
= 0;
1122 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1125 /* Find the first transfer/do statement. */
1126 for (curr
= code
; curr
; curr
= curr
->next
)
1128 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1132 /* Ensure it is the only transfer/do statement because cases like
1134 write (*,*) (a(i), b(i), i=1,4)
1136 cannot be optimized. */
1138 if (!curr
|| curr
->next
)
1141 if (curr
->op
== EXEC_DO
)
1143 if (curr
->ext
.iterator
->var
->ref
)
1145 ds_push
.prev
= stack_top
;
1146 ds_push
.iter
= curr
->ext
.iterator
;
1147 ds_push
.code
= curr
;
1148 stack_top
= &ds_push
;
1149 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1151 if (curr
!= stack_top
->code
&& !*has_reached
)
1153 curr
->block
->next
= NULL
;
1154 gfc_free_statements (curr
);
1157 *has_reached
= true;
1163 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1165 /* FIXME: Workaround for PR 80945 - array slices with deferred character
1166 lenghts do not work. Remove this section when the PR is fixed. */
1168 if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
1171 /* End of section to be removed. */
1174 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1177 /* Find the iterators belonging to each variable and check conditions. */
1178 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1180 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1181 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1184 start
= ref
->u
.ar
.start
[i
];
1185 gfc_simplify_expr (start
, 0);
1186 switch (start
->expr_type
)
1190 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1194 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1195 if (!stack_top
|| !stack_top
->iter
1196 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1198 /* Check for (a(i,i), i=1,3). */
1202 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1209 iters
[i
] = stack_top
->iter
;
1210 stack_top
= stack_top
->prev
;
1218 switch (start
->value
.op
.op
)
1220 case INTRINSIC_PLUS
:
1221 case INTRINSIC_TIMES
:
1222 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1223 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1225 case INTRINSIC_MINUS
:
1226 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1227 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1228 || start
->value
.op
.op1
->ref
)
1230 if (!stack_top
|| !stack_top
->iter
1231 || stack_top
->iter
->var
->symtree
1232 != start
->value
.op
.op1
->symtree
)
1234 iters
[i
] = stack_top
->iter
;
1235 stack_top
= stack_top
->prev
;
1247 /* Create new expr. */
1248 new_e
= gfc_copy_expr (curr
->expr1
);
1249 new_e
->expr_type
= EXPR_VARIABLE
;
1250 new_e
->rank
= future_rank
;
1251 if (curr
->expr1
->shape
)
1252 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1254 /* Assign new starts, ends and strides if necessary. */
1255 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1259 start
= ref
->u
.ar
.start
[i
];
1260 switch (start
->expr_type
)
1263 gfc_internal_error ("bad expression");
1266 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1267 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1268 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1269 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1270 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1271 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1274 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1275 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1276 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1277 expr
= gfc_copy_expr (start
);
1278 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1279 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1280 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1281 expr
= gfc_copy_expr (start
);
1282 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1283 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1284 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1285 switch (start
->value
.op
.op
)
1287 case INTRINSIC_MINUS
:
1288 case INTRINSIC_PLUS
:
1289 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1291 case INTRINSIC_TIMES
:
1292 expr
= gfc_copy_expr (start
);
1293 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1294 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1295 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1298 gfc_internal_error ("bad op");
1302 gfc_internal_error ("bad expression");
1305 curr
->expr1
= new_e
;
1307 /* Insert modified statement. Check whether the statement needs to be
1308 inserted at the lowest level. */
1309 if (!stack_top
->iter
)
1313 curr
->next
= prev
->next
->next
;
1318 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1319 stack_top
->code
->block
->next
= curr
;
1323 stack_top
->code
->block
->next
= curr
;
1327 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1328 tries to optimize its block. */
1331 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1332 void *data ATTRIBUTE_UNUSED
)
1334 gfc_code
**curr
, *prev
= NULL
;
1335 struct do_stack write
, first
;
1339 || ((*code
)->block
->op
!= EXEC_WRITE
1340 && (*code
)->block
->op
!= EXEC_READ
))
1348 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1350 if ((*curr
)->op
== EXEC_DO
)
1352 first
.prev
= &write
;
1353 first
.iter
= (*curr
)->ext
.iterator
;
1356 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1364 /* Optimize a namespace, including all contained namespaces.
1365 flag_frontend_optimize and flag_fronend_loop_interchange are
1366 handled separately. */
1369 optimize_namespace (gfc_namespace
*ns
)
1371 gfc_namespace
*saved_ns
= gfc_current_ns
;
1373 gfc_current_ns
= ns
;
1376 in_assoc_list
= false;
1377 in_omp_workshare
= false;
1379 if (flag_frontend_optimize
)
1381 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1382 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1383 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1384 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1385 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1386 if (flag_inline_matmul_limit
!= 0)
1392 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1397 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1399 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1404 if (flag_frontend_loop_interchange
)
1405 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1408 /* BLOCKs are handled in the expression walker below. */
1409 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1411 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1412 optimize_namespace (ns
);
1414 gfc_current_ns
= saved_ns
;
1417 /* Handle dependencies for allocatable strings which potentially redefine
1418 themselves in an assignment. */
1421 realloc_strings (gfc_namespace
*ns
)
1424 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1426 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1428 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1429 realloc_strings (ns
);
1435 optimize_reduction (gfc_namespace
*ns
)
1438 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1439 callback_reduction
, NULL
);
1441 /* BLOCKs are handled in the expression walker below. */
1442 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1444 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1445 optimize_reduction (ns
);
1449 /* Replace code like
1452 a = matmul(b,c) ; a = a + d
1453 where the array function is not elemental and not allocatable
1454 and does not depend on the left-hand side.
1458 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1466 if (e
->expr_type
== EXPR_OP
)
1468 switch (e
->value
.op
.op
)
1470 /* Unary operators and exponentiation: Only look at a single
1473 case INTRINSIC_UPLUS
:
1474 case INTRINSIC_UMINUS
:
1475 case INTRINSIC_PARENTHESES
:
1476 case INTRINSIC_POWER
:
1477 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1481 case INTRINSIC_CONCAT
:
1482 /* Do not do string concatenations. */
1486 /* Binary operators. */
1487 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1490 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1496 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1497 && ! (e
->value
.function
.esym
1498 && (e
->value
.function
.esym
->attr
.elemental
1499 || e
->value
.function
.esym
->attr
.allocatable
1500 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1501 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1502 && ! (e
->value
.function
.isym
1503 && (e
->value
.function
.isym
->elemental
1504 || e
->ts
.type
!= c
->expr1
->ts
.type
1505 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1506 && ! gfc_inline_intrinsic_function_p (e
))
1512 /* Insert a new assignment statement after the current one. */
1513 n
= XCNEW (gfc_code
);
1514 n
->op
= EXEC_ASSIGN
;
1519 n
->expr1
= gfc_copy_expr (c
->expr1
);
1520 n
->expr2
= c
->expr2
;
1521 new_expr
= gfc_copy_expr (c
->expr1
);
1529 /* Nothing to optimize. */
1533 /* Remove unneeded TRIMs at the end of expressions. */
1536 remove_trim (gfc_expr
*rhs
)
1544 /* Check for a // b // trim(c). Looping is probably not
1545 necessary because the parser usually generates
1546 (// (// a b ) trim(c) ) , but better safe than sorry. */
1548 while (rhs
->expr_type
== EXPR_OP
1549 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1550 rhs
= rhs
->value
.op
.op2
;
1552 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1553 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1555 strip_function_call (rhs
);
1556 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1564 /* Optimizations for an assignment. */
1567 optimize_assignment (gfc_code
* c
)
1569 gfc_expr
*lhs
, *rhs
;
1574 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1576 /* Optimize a = trim(b) to a = b. */
1579 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1580 if (is_empty_string (rhs
))
1581 rhs
->value
.character
.length
= 0;
1584 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1585 optimize_binop_array_assignment (c
, &rhs
, false);
1589 /* Remove an unneeded function call, modifying the expression.
1590 This replaces the function call with the value of its
1591 first argument. The rest of the argument list is freed. */
1594 strip_function_call (gfc_expr
*e
)
1597 gfc_actual_arglist
*a
;
1599 a
= e
->value
.function
.actual
;
1601 /* We should have at least one argument. */
1602 gcc_assert (a
->expr
!= NULL
);
1606 /* Free the remaining arglist, if any. */
1608 gfc_free_actual_arglist (a
->next
);
1610 /* Graft the argument expression onto the original function. */
1616 /* Optimization of lexical comparison functions. */
1619 optimize_lexical_comparison (gfc_expr
*e
)
1621 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1624 switch (e
->value
.function
.isym
->id
)
1627 return optimize_comparison (e
, INTRINSIC_LE
);
1630 return optimize_comparison (e
, INTRINSIC_GE
);
1633 return optimize_comparison (e
, INTRINSIC_GT
);
1636 return optimize_comparison (e
, INTRINSIC_LT
);
1644 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1645 do CHARACTER because of possible pessimization involving character
1649 combine_array_constructor (gfc_expr
*e
)
1652 gfc_expr
*op1
, *op2
;
1655 gfc_constructor
*c
, *new_c
;
1656 gfc_constructor_base oldbase
, newbase
;
1661 /* Array constructors have rank one. */
1665 /* Don't try to combine association lists, this makes no sense
1666 and leads to an ICE. */
1670 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1671 if (forall_level
> 0)
1674 /* Inside an iterator, things can get hairy; we are likely to create
1675 an invalid temporary variable. */
1676 if (iterator_level
> 0)
1679 op1
= e
->value
.op
.op1
;
1680 op2
= e
->value
.op
.op2
;
1685 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1686 scalar_first
= false;
1687 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1689 scalar_first
= true;
1690 op1
= e
->value
.op
.op2
;
1691 op2
= e
->value
.op
.op1
;
1696 if (op2
->ts
.type
== BT_CHARACTER
)
1699 /* This might be an expanded constructor with very many constant values. If
1700 we perform the operation here, we might end up with a long compile time
1701 and actually longer execution time, so a length bound is in order here.
1702 If the constructor constains something which is not a constant, it did
1703 not come from an expansion, so leave it alone. */
1705 #define CONSTR_LEN_MAX 4
1707 oldbase
= op1
->value
.constructor
;
1711 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1713 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1721 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1724 #undef CONSTR_LEN_MAX
1727 e
->expr_type
= EXPR_ARRAY
;
1729 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1731 for (c
= gfc_constructor_first (oldbase
); c
;
1732 c
= gfc_constructor_next (c
))
1734 new_expr
= gfc_get_expr ();
1735 new_expr
->ts
= e
->ts
;
1736 new_expr
->expr_type
= EXPR_OP
;
1737 new_expr
->rank
= c
->expr
->rank
;
1738 new_expr
->where
= c
->expr
->where
;
1739 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1743 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1744 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1748 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1749 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1752 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1753 new_c
->iterator
= c
->iterator
;
1757 gfc_free_expr (op1
);
1758 gfc_free_expr (op2
);
1759 gfc_free_expr (scalar
);
1761 e
->value
.constructor
= newbase
;
1765 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1766 2**k into ishift(1,k) */
1769 optimize_power (gfc_expr
*e
)
1771 gfc_expr
*op1
, *op2
;
1772 gfc_expr
*iand
, *ishft
;
1774 if (e
->ts
.type
!= BT_INTEGER
)
1777 op1
= e
->value
.op
.op1
;
1779 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1782 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1784 gfc_free_expr (op1
);
1786 op2
= e
->value
.op
.op2
;
1791 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1792 "_internal_iand", e
->where
, 2, op2
,
1793 gfc_get_int_expr (e
->ts
.kind
,
1796 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1797 "_internal_ishft", e
->where
, 2, iand
,
1798 gfc_get_int_expr (e
->ts
.kind
,
1801 e
->value
.op
.op
= INTRINSIC_MINUS
;
1802 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1803 e
->value
.op
.op2
= ishft
;
1806 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1808 gfc_free_expr (op1
);
1810 op2
= e
->value
.op
.op2
;
1814 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1815 "_internal_ishft", e
->where
, 2,
1816 gfc_get_int_expr (e
->ts
.kind
,
1823 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1825 op2
= e
->value
.op
.op2
;
1829 gfc_free_expr (op1
);
1830 gfc_free_expr (op2
);
1832 e
->expr_type
= EXPR_CONSTANT
;
1833 e
->value
.op
.op1
= NULL
;
1834 e
->value
.op
.op2
= NULL
;
1835 mpz_init_set_si (e
->value
.integer
, 1);
1836 /* Typespec and location are still OK. */
1843 /* Recursive optimization of operators. */
1846 optimize_op (gfc_expr
*e
)
1850 gfc_intrinsic_op op
= e
->value
.op
.op
;
1854 /* Only use new-style comparisons. */
1857 case INTRINSIC_EQ_OS
:
1861 case INTRINSIC_GE_OS
:
1865 case INTRINSIC_LE_OS
:
1869 case INTRINSIC_NE_OS
:
1873 case INTRINSIC_GT_OS
:
1877 case INTRINSIC_LT_OS
:
1893 changed
= optimize_comparison (e
, op
);
1896 /* Look at array constructors. */
1897 case INTRINSIC_PLUS
:
1898 case INTRINSIC_MINUS
:
1899 case INTRINSIC_TIMES
:
1900 case INTRINSIC_DIVIDE
:
1901 return combine_array_constructor (e
) || changed
;
1903 case INTRINSIC_POWER
:
1904 return optimize_power (e
);
1914 /* Return true if a constant string contains only blanks. */
1917 is_empty_string (gfc_expr
*e
)
1921 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1924 for (i
=0; i
< e
->value
.character
.length
; i
++)
1926 if (e
->value
.character
.string
[i
] != ' ')
1934 /* Insert a call to the intrinsic len_trim. Use a different name for
1935 the symbol tree so we don't run into trouble when the user has
1936 renamed len_trim for some reason. */
1939 get_len_trim_call (gfc_expr
*str
, int kind
)
1942 gfc_actual_arglist
*actual_arglist
, *next
;
1944 fcn
= gfc_get_expr ();
1945 fcn
->expr_type
= EXPR_FUNCTION
;
1946 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1947 actual_arglist
= gfc_get_actual_arglist ();
1948 actual_arglist
->expr
= str
;
1949 next
= gfc_get_actual_arglist ();
1950 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1951 actual_arglist
->next
= next
;
1953 fcn
->value
.function
.actual
= actual_arglist
;
1954 fcn
->where
= str
->where
;
1955 fcn
->ts
.type
= BT_INTEGER
;
1956 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1958 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1959 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1960 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1961 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1962 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1963 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1964 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1965 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1970 /* Optimize expressions for equality. */
1973 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1975 gfc_expr
*op1
, *op2
;
1979 gfc_actual_arglist
*firstarg
, *secondarg
;
1981 if (e
->expr_type
== EXPR_OP
)
1985 op1
= e
->value
.op
.op1
;
1986 op2
= e
->value
.op
.op2
;
1988 else if (e
->expr_type
== EXPR_FUNCTION
)
1990 /* One of the lexical comparison functions. */
1991 firstarg
= e
->value
.function
.actual
;
1992 secondarg
= firstarg
->next
;
1993 op1
= firstarg
->expr
;
1994 op2
= secondarg
->expr
;
1999 /* Strip off unneeded TRIM calls from string comparisons. */
2001 change
= remove_trim (op1
);
2003 if (remove_trim (op2
))
2006 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2007 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2008 handles them well). However, there are also cases that need a non-scalar
2009 argument. For example the any intrinsic. See PR 45380. */
2013 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2015 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2016 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2018 bool empty_op1
, empty_op2
;
2019 empty_op1
= is_empty_string (op1
);
2020 empty_op2
= is_empty_string (op2
);
2022 if (empty_op1
|| empty_op2
)
2028 /* This can only happen when an error for comparing
2029 characters of different kinds has already been issued. */
2030 if (empty_op1
&& empty_op2
)
2033 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2034 str
= empty_op1
? op2
: op1
;
2036 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2040 gfc_free_expr (op1
);
2042 gfc_free_expr (op2
);
2046 e
->value
.op
.op1
= fcn
;
2047 e
->value
.op
.op2
= zero
;
2052 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2054 if (flag_finite_math_only
2055 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2056 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2058 eq
= gfc_dep_compare_expr (op1
, op2
);
2061 /* Replace A // B < A // C with B < C, and A // B < C // B
2063 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2064 && op1
->expr_type
== EXPR_OP
2065 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2066 && op2
->expr_type
== EXPR_OP
2067 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2069 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2070 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2071 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2072 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2074 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2076 /* Watch out for 'A ' // x vs. 'A' // x. */
2078 if (op1_left
->expr_type
== EXPR_CONSTANT
2079 && op2_left
->expr_type
== EXPR_CONSTANT
2080 && op1_left
->value
.character
.length
2081 != op2_left
->value
.character
.length
)
2089 firstarg
->expr
= op1_right
;
2090 secondarg
->expr
= op2_right
;
2094 e
->value
.op
.op1
= op1_right
;
2095 e
->value
.op
.op2
= op2_right
;
2097 optimize_comparison (e
, op
);
2101 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2107 firstarg
->expr
= op1_left
;
2108 secondarg
->expr
= op2_left
;
2112 e
->value
.op
.op1
= op1_left
;
2113 e
->value
.op
.op2
= op2_left
;
2116 optimize_comparison (e
, op
);
2123 /* eq can only be -1, 0 or 1 at this point. */
2151 gfc_internal_error ("illegal OP in optimize_comparison");
2155 /* Replace the expression by a constant expression. The typespec
2156 and where remains the way it is. */
2159 e
->expr_type
= EXPR_CONSTANT
;
2160 e
->value
.logical
= result
;
2168 /* Optimize a trim function by replacing it with an equivalent substring
2169 involving a call to len_trim. This only works for expressions where
2170 variables are trimmed. Return true if anything was modified. */
2173 optimize_trim (gfc_expr
*e
)
2178 gfc_ref
**rr
= NULL
;
2180 /* Don't do this optimization within an argument list, because
2181 otherwise aliasing issues may occur. */
2183 if (count_arglist
!= 1)
2186 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2187 || e
->value
.function
.isym
== NULL
2188 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2191 a
= e
->value
.function
.actual
->expr
;
2193 if (a
->expr_type
!= EXPR_VARIABLE
)
2196 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2198 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2201 /* Follow all references to find the correct place to put the newly
2202 created reference. FIXME: Also handle substring references and
2203 array references. Array references cause strange regressions at
2208 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2210 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2215 strip_function_call (e
);
2220 /* Create the reference. */
2222 ref
= gfc_get_ref ();
2223 ref
->type
= REF_SUBSTRING
;
2225 /* Set the start of the reference. */
2227 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2229 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2231 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2233 /* Set the end of the reference to the call to len_trim. */
2235 ref
->u
.ss
.end
= fcn
;
2236 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2241 /* Optimize minloc(b), where b is rank 1 array, into
2242 (/ minloc(b, dim=1) /), and similarly for maxloc,
2243 as the latter forms are expanded inline. */
2246 optimize_minmaxloc (gfc_expr
**e
)
2249 gfc_actual_arglist
*a
;
2253 || fn
->value
.function
.actual
== NULL
2254 || fn
->value
.function
.actual
->expr
== NULL
2255 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2258 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2259 (*e
)->shape
= fn
->shape
;
2262 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2264 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2265 strcpy (name
, fn
->value
.function
.name
);
2266 p
= strstr (name
, "loc0");
2268 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2269 if (fn
->value
.function
.actual
->next
)
2271 a
= fn
->value
.function
.actual
->next
;
2272 gcc_assert (a
->expr
== NULL
);
2276 a
= gfc_get_actual_arglist ();
2277 fn
->value
.function
.actual
->next
= a
;
2279 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2281 mpz_set_ui (a
->expr
->value
.integer
, 1);
2284 /* Callback function for code checking that we do not pass a DO variable to an
2285 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2288 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2289 void *data ATTRIBUTE_UNUSED
)
2293 gfc_formal_arglist
*f
;
2294 gfc_actual_arglist
*a
;
2301 /* If the doloop_list grew, we have to truncate it here. */
2303 if ((unsigned) doloop_level
< doloop_list
.length())
2304 doloop_list
.truncate (doloop_level
);
2311 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2316 loop
.branch_level
= if_level
+ select_level
;
2317 loop
.seen_goto
= false;
2318 doloop_list
.safe_push (loop
);
2321 /* If anything could transfer control away from a suspicious
2322 subscript, make sure to set seen_goto in the current DO loop
2327 case EXEC_ERROR_STOP
:
2333 if (co
->ext
.open
->err
)
2338 if (co
->ext
.close
->err
)
2342 case EXEC_BACKSPACE
:
2347 if (co
->ext
.filepos
->err
)
2352 if (co
->ext
.filepos
->err
)
2358 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2363 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2364 loop
.seen_goto
= true;
2369 if (co
->resolved_sym
== NULL
)
2372 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2374 /* Withot a formal arglist, there is only unknown INTENT,
2375 which we don't check for. */
2383 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2391 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2393 if (a
->expr
&& a
->expr
->symtree
2394 && a
->expr
->symtree
->n
.sym
== do_sym
)
2396 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2397 gfc_error_now ("Variable %qs at %L set to undefined "
2398 "value inside loop beginning at %L as "
2399 "INTENT(OUT) argument to subroutine %qs",
2400 do_sym
->name
, &a
->expr
->where
,
2401 &(doloop_list
[i
].c
->loc
),
2402 co
->symtree
->n
.sym
->name
);
2403 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2404 gfc_error_now ("Variable %qs at %L not definable inside "
2405 "loop beginning at %L as INTENT(INOUT) "
2406 "argument to subroutine %qs",
2407 do_sym
->name
, &a
->expr
->where
,
2408 &(doloop_list
[i
].c
->loc
),
2409 co
->symtree
->n
.sym
->name
);
2420 if (seen_goto
&& doloop_level
> 0)
2421 doloop_list
[doloop_level
-1].seen_goto
= true;
2426 /* Callback function to warn about different things within DO loops. */
2429 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2430 void *data ATTRIBUTE_UNUSED
)
2434 if (doloop_list
.length () == 0)
2437 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2440 last
= &doloop_list
.last();
2441 if (last
->seen_goto
&& !warn_do_subscript
)
2444 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2456 /* Callback function - if the expression is the variable in data->sym,
2457 replace it with a constant from data->val. */
2460 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2467 if (ex
->expr_type
!= EXPR_VARIABLE
)
2470 d
= (insert_index_t
*) data
;
2471 if (ex
->symtree
->n
.sym
!= d
->sym
)
2474 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2475 mpz_set (n
->value
.integer
, d
->val
);
2482 /* In the expression e, replace occurrences of the variable sym with
2483 val. If this results in a constant expression, return true and
2484 return the value in ret. Return false if the expression already
2485 is a constant. Caller has to clear ret in that case. */
2488 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2491 insert_index_t data
;
2494 if (e
->expr_type
== EXPR_CONSTANT
)
2497 n
= gfc_copy_expr (e
);
2499 mpz_init_set (data
.val
, val
);
2500 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2501 gfc_simplify_expr (n
, 0);
2503 if (n
->expr_type
== EXPR_CONSTANT
)
2506 mpz_init_set (ret
, n
->value
.integer
);
2511 mpz_clear (data
.val
);
2517 /* Check array subscripts for possible out-of-bounds accesses in DO
2518 loops with constant bounds. */
2521 do_subscript (gfc_expr
**e
)
2531 /* Constants are already checked. */
2532 if (v
->expr_type
== EXPR_CONSTANT
)
2535 /* Wrong warnings will be generated in an associate list. */
2539 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2541 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2544 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2547 mpz_t do_start
, do_step
, do_end
;
2548 bool have_do_start
, have_do_end
;
2549 bool error_not_proven
;
2556 /* If we are within a branch, or a goto or equivalent
2557 was seen in the DO loop before, then we cannot prove that
2558 this expression is actually evaluated. Don't do anything
2559 unless we want to see it all. */
2560 error_not_proven
= lp
->seen_goto
2561 || lp
->branch_level
< if_level
+ select_level
;
2563 if (error_not_proven
&& !warn_do_subscript
)
2566 if (error_not_proven
)
2567 warn
= OPT_Wdo_subscript
;
2571 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2572 if (do_sym
->ts
.type
!= BT_INTEGER
)
2575 /* If we do not know about the stepsize, the loop may be zero trip.
2576 Do not warn in this case. */
2578 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2579 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2583 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2585 have_do_start
= true;
2586 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2589 have_do_start
= false;
2592 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2595 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2598 have_do_end
= false;
2600 if (!have_do_start
&& !have_do_end
)
2603 /* May have to correct the end value if the step does not equal
2605 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2611 mpz_sub (diff
, do_end
, do_start
);
2612 mpz_tdiv_r (rem
, diff
, do_step
);
2613 mpz_sub (do_end
, do_end
, rem
);
2618 for (i
= 0; i
< ar
->dimen
; i
++)
2621 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2622 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2624 if (ar
->as
->lower
[i
]
2625 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2626 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2627 gfc_warning (warn
, "Array reference at %L out of bounds "
2628 "(%ld < %ld) in loop beginning at %L",
2629 &ar
->start
[i
]->where
, mpz_get_si (val
),
2630 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2631 &doloop_list
[j
].c
->loc
);
2633 if (ar
->as
->upper
[i
]
2634 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2635 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2636 gfc_warning (warn
, "Array reference at %L out of bounds "
2637 "(%ld > %ld) in loop beginning at %L",
2638 &ar
->start
[i
]->where
, mpz_get_si (val
),
2639 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2640 &doloop_list
[j
].c
->loc
);
2645 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2646 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2648 if (ar
->as
->lower
[i
]
2649 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2650 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2651 gfc_warning (warn
, "Array reference at %L out of bounds "
2652 "(%ld < %ld) in loop beginning at %L",
2653 &ar
->start
[i
]->where
, mpz_get_si (val
),
2654 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2655 &doloop_list
[j
].c
->loc
);
2657 if (ar
->as
->upper
[i
]
2658 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2659 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2660 gfc_warning (warn
, "Array reference at %L out of bounds "
2661 "(%ld > %ld) in loop beginning at %L",
2662 &ar
->start
[i
]->where
, mpz_get_si (val
),
2663 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2664 &doloop_list
[j
].c
->loc
);
2674 /* Function for functions checking that we do not pass a DO variable
2675 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2678 do_intent (gfc_expr
**e
)
2680 gfc_formal_arglist
*f
;
2681 gfc_actual_arglist
*a
;
2688 if (expr
->expr_type
!= EXPR_FUNCTION
)
2691 /* Intrinsic functions don't modify their arguments. */
2693 if (expr
->value
.function
.isym
)
2696 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2698 /* Without a formal arglist, there is only unknown INTENT,
2699 which we don't check for. */
2703 a
= expr
->value
.function
.actual
;
2707 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2714 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2716 if (a
->expr
&& a
->expr
->symtree
2717 && a
->expr
->symtree
->n
.sym
== do_sym
)
2719 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2720 gfc_error_now ("Variable %qs at %L set to undefined value "
2721 "inside loop beginning at %L as INTENT(OUT) "
2722 "argument to function %qs", do_sym
->name
,
2723 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2724 expr
->symtree
->n
.sym
->name
);
2725 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2726 gfc_error_now ("Variable %qs at %L not definable inside loop"
2727 " beginning at %L as INTENT(INOUT) argument to"
2728 " function %qs", do_sym
->name
,
2729 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2730 expr
->symtree
->n
.sym
->name
);
2741 doloop_warn (gfc_namespace
*ns
)
2743 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2746 /* This selction deals with inlining calls to MATMUL. */
2748 /* Replace calls to matmul outside of straight assignments with a temporary
2749 variable so that later inlining will work. */
2752 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2756 bool *found
= (bool *) data
;
2760 if (e
->expr_type
!= EXPR_FUNCTION
2761 || e
->value
.function
.isym
== NULL
2762 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2765 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2769 /* Check if this is already in the form c = matmul(a,b). */
2771 if ((*current_code
)->expr2
== e
)
2774 n
= create_var (e
, "matmul");
2776 /* If create_var is unable to create a variable (for example if
2777 -fno-realloc-lhs is in force with a variable that does not have bounds
2778 known at compile-time), just return. */
2788 /* Set current_code and associated variables so that matmul_to_var_expr can
2792 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2793 void *data ATTRIBUTE_UNUSED
)
2795 if (current_code
!= c
)
2798 inserted_block
= NULL
;
2799 changed_statement
= NULL
;
2806 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2807 for a and b if there is a dependency between the arguments and the
2808 result variable or if a or b are the result of calculations that cannot
2809 be handled by the inliner. */
2812 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2813 void *data ATTRIBUTE_UNUSED
)
2815 gfc_expr
*expr1
, *expr2
;
2817 gfc_actual_arglist
*a
, *b
;
2819 gfc_expr
*matrix_a
, *matrix_b
;
2820 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2824 if (co
->op
!= EXEC_ASSIGN
)
2827 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2831 /* This has some duplication with inline_matmul_assign. This
2832 is because the creation of temporary variables could still fail,
2833 and inline_matmul_assign still needs to be able to handle these
2838 if (expr2
->expr_type
!= EXPR_FUNCTION
2839 || expr2
->value
.function
.isym
== NULL
2840 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2844 a
= expr2
->value
.function
.actual
;
2845 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2846 if (matrix_a
!= NULL
)
2848 if (matrix_a
->expr_type
== EXPR_VARIABLE
2849 && (gfc_check_dependency (matrix_a
, expr1
, true)
2850 || has_dimen_vector_ref (matrix_a
)))
2858 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2859 if (matrix_b
!= NULL
)
2861 if (matrix_b
->expr_type
== EXPR_VARIABLE
2862 && (gfc_check_dependency (matrix_b
, expr1
, true)
2863 || has_dimen_vector_ref (matrix_b
)))
2869 if (!a_tmp
&& !b_tmp
)
2873 inserted_block
= NULL
;
2874 changed_statement
= NULL
;
2878 at
= create_var (a
->expr
,"mma");
2885 bt
= create_var (b
->expr
,"mmb");
2892 /* Auxiliary function to build and simplify an array inquiry function.
2893 dim is zero-based. */
2896 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2899 gfc_expr
*dim_arg
, *kind
;
2905 case GFC_ISYM_LBOUND
:
2906 name
= "_gfortran_lbound";
2909 case GFC_ISYM_UBOUND
:
2910 name
= "_gfortran_ubound";
2914 name
= "_gfortran_size";
2921 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2922 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2923 gfc_index_integer_kind
);
2925 ec
= gfc_copy_expr (e
);
2926 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2928 gfc_simplify_expr (fcn
, 0);
2932 /* Builds a logical expression. */
2935 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2940 ts
.type
= BT_LOGICAL
;
2941 ts
.kind
= gfc_default_logical_kind
;
2942 res
= gfc_get_expr ();
2943 res
->where
= e1
->where
;
2944 res
->expr_type
= EXPR_OP
;
2945 res
->value
.op
.op
= op
;
2946 res
->value
.op
.op1
= e1
;
2947 res
->value
.op
.op2
= e2
;
2954 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2955 compatible typespecs. */
2958 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2962 res
= gfc_get_expr ();
2964 res
->where
= e1
->where
;
2965 res
->expr_type
= EXPR_OP
;
2966 res
->value
.op
.op
= op
;
2967 res
->value
.op
.op1
= e1
;
2968 res
->value
.op
.op2
= e2
;
2969 gfc_simplify_expr (res
, 0);
2973 /* Generate the IF statement for a runtime check if we want to do inlining or
2974 not - putting in the code for both branches and putting it into the syntax
2975 tree is the caller's responsibility. For fixed array sizes, this should be
2976 removed by DCE. Only called for rank-two matrices A and B. */
2979 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2981 gfc_expr
*inline_limit
;
2982 gfc_code
*if_1
, *if_2
, *else_2
;
2983 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2987 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2989 /* Calculation is done in real to avoid integer overflow. */
2991 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2993 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2995 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2998 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2999 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3000 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3004 ts
.kind
= gfc_default_real_kind
;
3005 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3006 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3007 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3009 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3010 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3012 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3013 gfc_simplify_expr (cond
, 0);
3015 else_2
= XCNEW (gfc_code
);
3016 else_2
->op
= EXEC_IF
;
3017 else_2
->loc
= a
->where
;
3019 if_2
= XCNEW (gfc_code
);
3022 if_2
->loc
= a
->where
;
3023 if_2
->block
= else_2
;
3025 if_1
= XCNEW (gfc_code
);
3028 if_1
->loc
= a
->where
;
3034 /* Insert code to issue a runtime error if the expressions are not equal. */
3037 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3040 gfc_code
*if_1
, *if_2
;
3042 gfc_actual_arglist
*a1
, *a2
, *a3
;
3044 gcc_assert (e1
->where
.lb
);
3045 /* Build the call to runtime_error. */
3046 c
= XCNEW (gfc_code
);
3050 /* Get a null-terminated message string. */
3052 a1
= gfc_get_actual_arglist ();
3053 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3054 msg
, strlen(msg
)+1);
3057 /* Pass the value of the first expression. */
3058 a2
= gfc_get_actual_arglist ();
3059 a2
->expr
= gfc_copy_expr (e1
);
3062 /* Pass the value of the second expression. */
3063 a3
= gfc_get_actual_arglist ();
3064 a3
->expr
= gfc_copy_expr (e2
);
3067 gfc_check_fe_runtime_error (c
->ext
.actual
);
3068 gfc_resolve_fe_runtime_error (c
);
3070 if_2
= XCNEW (gfc_code
);
3072 if_2
->loc
= e1
->where
;
3075 if_1
= XCNEW (gfc_code
);
3078 if_1
->loc
= e1
->where
;
3080 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3081 gfc_simplify_expr (cond
, 0);
3087 /* Handle matrix reallocation. Caller is responsible to insert into
3090 For the two-dimensional case, build
3092 if (allocated(c)) then
3093 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3095 allocate (c(size(a,1), size(b,2)))
3098 allocate (c(size(a,1),size(b,2)))
3101 and for the other cases correspondingly.
3105 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3106 enum matrix_case m_case
)
3109 gfc_expr
*allocated
, *alloc_expr
;
3110 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3111 gfc_code
*else_alloc
;
3112 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3114 gfc_expr
*cond
, *ne1
, *ne2
;
3116 if (warn_realloc_lhs
)
3117 gfc_warning (OPT_Wrealloc_lhs
,
3118 "Code for reallocating the allocatable array at %L will "
3119 "be added", &c
->where
);
3121 alloc_expr
= gfc_copy_expr (c
);
3123 ar
= gfc_find_array_ref (alloc_expr
);
3124 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3126 /* c comes in as a full ref. Change it into a copy and make it into an
3127 element ref so it has the right form for for ALLOCATE. In the same
3128 switch statement, also generate the size comparison for the secod IF
3131 ar
->type
= AR_ELEMENT
;
3136 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3137 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3138 ne1
= build_logical_expr (INTRINSIC_NE
,
3139 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3140 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3141 ne2
= build_logical_expr (INTRINSIC_NE
,
3142 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3143 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3144 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3148 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3149 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3151 ne1
= build_logical_expr (INTRINSIC_NE
,
3152 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3153 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3154 ne2
= build_logical_expr (INTRINSIC_NE
,
3155 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3156 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3157 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3162 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3163 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3165 ne1
= build_logical_expr (INTRINSIC_NE
,
3166 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3167 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3168 ne2
= build_logical_expr (INTRINSIC_NE
,
3169 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3170 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3171 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3175 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3176 cond
= build_logical_expr (INTRINSIC_NE
,
3177 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3178 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3182 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3183 cond
= build_logical_expr (INTRINSIC_NE
,
3184 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3185 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3193 gfc_simplify_expr (cond
, 0);
3195 /* We need two identical allocate statements in two
3196 branches of the IF statement. */
3198 allocate1
= XCNEW (gfc_code
);
3199 allocate1
->op
= EXEC_ALLOCATE
;
3200 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3201 allocate1
->loc
= c
->where
;
3202 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3204 allocate_else
= XCNEW (gfc_code
);
3205 allocate_else
->op
= EXEC_ALLOCATE
;
3206 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3207 allocate_else
->loc
= c
->where
;
3208 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3210 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3211 "_gfortran_allocated", c
->where
,
3212 1, gfc_copy_expr (c
));
3214 deallocate
= XCNEW (gfc_code
);
3215 deallocate
->op
= EXEC_DEALLOCATE
;
3216 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3217 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3218 deallocate
->next
= allocate1
;
3219 deallocate
->loc
= c
->where
;
3221 if_size_2
= XCNEW (gfc_code
);
3222 if_size_2
->op
= EXEC_IF
;
3223 if_size_2
->expr1
= cond
;
3224 if_size_2
->loc
= c
->where
;
3225 if_size_2
->next
= deallocate
;
3227 if_size_1
= XCNEW (gfc_code
);
3228 if_size_1
->op
= EXEC_IF
;
3229 if_size_1
->block
= if_size_2
;
3230 if_size_1
->loc
= c
->where
;
3232 else_alloc
= XCNEW (gfc_code
);
3233 else_alloc
->op
= EXEC_IF
;
3234 else_alloc
->loc
= c
->where
;
3235 else_alloc
->next
= allocate_else
;
3237 if_alloc_2
= XCNEW (gfc_code
);
3238 if_alloc_2
->op
= EXEC_IF
;
3239 if_alloc_2
->expr1
= allocated
;
3240 if_alloc_2
->loc
= c
->where
;
3241 if_alloc_2
->next
= if_size_1
;
3242 if_alloc_2
->block
= else_alloc
;
3244 if_alloc_1
= XCNEW (gfc_code
);
3245 if_alloc_1
->op
= EXEC_IF
;
3246 if_alloc_1
->block
= if_alloc_2
;
3247 if_alloc_1
->loc
= c
->where
;
3252 /* Callback function for has_function_or_op. */
3255 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3256 void *data ATTRIBUTE_UNUSED
)
3261 return (*e
)->expr_type
== EXPR_FUNCTION
3262 || (*e
)->expr_type
== EXPR_OP
;
3265 /* Returns true if the expression contains a function. */
3268 has_function_or_op (gfc_expr
**e
)
3273 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3276 /* Freeze (assign to a temporary variable) a single expression. */
3279 freeze_expr (gfc_expr
**ep
)
3282 if (has_function_or_op (ep
))
3284 ne
= create_var (*ep
, "freeze");
3289 /* Go through an expression's references and assign them to temporary
3290 variables if they contain functions. This is usually done prior to
3291 front-end scalarization to avoid multiple invocations of functions. */
3294 freeze_references (gfc_expr
*e
)
3300 for (r
=e
->ref
; r
; r
=r
->next
)
3302 if (r
->type
== REF_SUBSTRING
)
3304 if (r
->u
.ss
.start
!= NULL
)
3305 freeze_expr (&r
->u
.ss
.start
);
3307 if (r
->u
.ss
.end
!= NULL
)
3308 freeze_expr (&r
->u
.ss
.end
);
3310 else if (r
->type
== REF_ARRAY
)
3319 for (i
=0; i
<ar
->dimen
; i
++)
3321 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3323 freeze_expr (&ar
->start
[i
]);
3324 freeze_expr (&ar
->end
[i
]);
3325 freeze_expr (&ar
->stride
[i
]);
3327 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3329 freeze_expr (&ar
->start
[i
]);
3335 for (i
=0; i
<ar
->dimen
; i
++)
3336 freeze_expr (&ar
->start
[i
]);
3346 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3349 convert_to_index_kind (gfc_expr
*e
)
3353 gcc_assert (e
!= NULL
);
3355 res
= gfc_copy_expr (e
);
3357 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3359 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3363 ts
.type
= BT_INTEGER
;
3364 ts
.kind
= gfc_index_integer_kind
;
3366 gfc_convert_type_warn (e
, &ts
, 2, 0);
3372 /* Function to create a DO loop including creation of the
3373 iteration variable. gfc_expr are copied.*/
3376 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3377 gfc_namespace
*ns
, char *vname
)
3380 char name
[GFC_MAX_SYMBOL_LEN
+1];
3381 gfc_symtree
*symtree
;
3386 /* Create an expression for the iteration variable. */
3388 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3390 sprintf (name
, "__var_%d_do", var_num
++);
3393 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3396 /* Create the loop variable. */
3398 symbol
= symtree
->n
.sym
;
3399 symbol
->ts
.type
= BT_INTEGER
;
3400 symbol
->ts
.kind
= gfc_index_integer_kind
;
3401 symbol
->attr
.flavor
= FL_VARIABLE
;
3402 symbol
->attr
.referenced
= 1;
3403 symbol
->attr
.dimension
= 0;
3404 symbol
->attr
.fe_temp
= 1;
3405 gfc_commit_symbol (symbol
);
3407 i
= gfc_get_expr ();
3408 i
->expr_type
= EXPR_VARIABLE
;
3412 i
->symtree
= symtree
;
3414 /* ... and the nested DO statements. */
3415 n
= XCNEW (gfc_code
);
3418 n
->ext
.iterator
= gfc_get_iterator ();
3419 n
->ext
.iterator
->var
= i
;
3420 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3421 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3423 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3425 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3428 n2
= XCNEW (gfc_code
);
3436 /* Get the upper bound of the DO loops for matmul along a dimension. This
3440 get_size_m1 (gfc_expr
*e
, int dimen
)
3445 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3447 res
= gfc_get_constant_expr (BT_INTEGER
,
3448 gfc_index_integer_kind
, &e
->where
);
3449 mpz_sub_ui (res
->value
.integer
, size
, 1);
3454 res
= get_operand (INTRINSIC_MINUS
,
3455 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3456 gfc_get_int_expr (gfc_index_integer_kind
,
3458 gfc_simplify_expr (res
, 0);
3464 /* Function to return a scalarized expression. It is assumed that indices are
3465 zero based to make generation of DO loops easier. A zero as index will
3466 access the first element along a dimension. Single element references will
3467 be skipped. A NULL as an expression will be replaced by a full reference.
3468 This assumes that the index loops have gfc_index_integer_kind, and that all
3469 references have been frozen. */
3472 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3481 e
= gfc_copy_expr(e_in
);
3485 ar
= gfc_find_array_ref (e
);
3487 /* We scalarize count_index variables, reducing the rank by count_index. */
3489 e
->rank
= rank
- count_index
;
3491 was_fullref
= ar
->type
== AR_FULL
;
3494 ar
->type
= AR_ELEMENT
;
3496 ar
->type
= AR_SECTION
;
3498 /* Loop over the indices. For each index, create the expression
3499 index * stride + lbound(e, dim). */
3502 for (i
=0; i
< ar
->dimen
; i
++)
3504 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3506 if (index
[i_index
] != NULL
)
3508 gfc_expr
*lbound
, *nindex
;
3511 loopvar
= gfc_copy_expr (index
[i_index
]);
3517 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3518 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3522 ts
.type
= BT_INTEGER
;
3523 ts
.kind
= gfc_index_integer_kind
;
3524 gfc_convert_type (tmp
, &ts
, 2);
3526 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3531 /* Calculate the lower bound of the expression. */
3534 lbound
= gfc_copy_expr (ar
->start
[i
]);
3535 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3539 ts
.type
= BT_INTEGER
;
3540 ts
.kind
= gfc_index_integer_kind
;
3541 gfc_convert_type (lbound
, &ts
, 2);
3550 lbound_e
= gfc_copy_expr (e_in
);
3552 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3553 if (ref
->type
== REF_ARRAY
3554 && (ref
->u
.ar
.type
== AR_FULL
3555 || ref
->u
.ar
.type
== AR_SECTION
))
3560 gfc_free_ref_list (ref
->next
);
3566 /* Look at full individual sections, like a(:). The first index
3567 is the lbound of a full ref. */
3573 for (j
= 0; j
< ar
->dimen
; j
++)
3575 gfc_free_expr (ar
->start
[j
]);
3576 ar
->start
[j
] = NULL
;
3577 gfc_free_expr (ar
->end
[j
]);
3579 gfc_free_expr (ar
->stride
[j
]);
3580 ar
->stride
[j
] = NULL
;
3583 /* We have to get rid of the shape, if there is one. Do
3584 so by freeing it and calling gfc_resolve to rebuild
3585 it, if necessary. */
3587 if (lbound_e
->shape
)
3588 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3590 lbound_e
->rank
= ar
->dimen
;
3591 gfc_resolve_expr (lbound_e
);
3593 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3595 gfc_free_expr (lbound_e
);
3598 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3600 gfc_free_expr (ar
->start
[i
]);
3601 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3603 gfc_free_expr (ar
->end
[i
]);
3605 gfc_free_expr (ar
->stride
[i
]);
3606 ar
->stride
[i
] = NULL
;
3607 gfc_simplify_expr (ar
->start
[i
], 0);
3609 else if (was_fullref
)
3611 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3620 /* Helper function to check for a dimen vector as subscript. */
3623 has_dimen_vector_ref (gfc_expr
*e
)
3628 ar
= gfc_find_array_ref (e
);
3630 if (ar
->type
== AR_FULL
)
3633 for (i
=0; i
<ar
->dimen
; i
++)
3634 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3640 /* If handed an expression of the form
3644 check if A can be handled by matmul and return if there is an uneven number
3645 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3646 otherwise. The caller has to check for the correct rank. */
3649 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3656 if (e
->expr_type
== EXPR_VARIABLE
)
3658 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3661 else if (e
->expr_type
== EXPR_FUNCTION
)
3663 if (e
->value
.function
.isym
== NULL
)
3666 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3668 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3669 *transpose
= !*transpose
;
3675 e
= e
->value
.function
.actual
->expr
;
3682 /* Inline assignments of the form c = matmul(a,b).
3683 Handle only the cases currently where b and c are rank-two arrays.
3685 This basically translates the code to
3691 do k=0, size(a, 2)-1
3692 do i=0, size(a, 1)-1
3693 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3694 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3695 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3696 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3705 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3706 void *data ATTRIBUTE_UNUSED
)
3709 gfc_expr
*expr1
, *expr2
;
3710 gfc_expr
*matrix_a
, *matrix_b
;
3711 gfc_actual_arglist
*a
, *b
;
3712 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3714 gfc_expr
*u1
, *u2
, *u3
;
3716 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3718 gfc_expr
*var_1
, *var_2
, *var_3
;
3721 gfc_intrinsic_op op_times
, op_plus
;
3722 enum matrix_case m_case
;
3724 gfc_code
*if_limit
= NULL
;
3725 gfc_code
**next_code_point
;
3726 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3728 if (co
->op
!= EXEC_ASSIGN
)
3734 /* The BLOCKS generated for the temporary variables and FORALL don't
3736 if (forall_level
> 0)
3739 /* For now don't do anything in OpenMP workshare, it confuses
3740 its translation, which expects only the allowed statements in there.
3741 We should figure out how to parallelize this eventually. */
3742 if (in_omp_workshare
)
3747 if (expr2
->expr_type
!= EXPR_FUNCTION
3748 || expr2
->value
.function
.isym
== NULL
3749 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3753 inserted_block
= NULL
;
3754 changed_statement
= NULL
;
3756 a
= expr2
->value
.function
.actual
;
3757 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3758 if (matrix_a
== NULL
)
3762 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3763 if (matrix_b
== NULL
)
3766 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3767 || has_dimen_vector_ref (matrix_b
))
3770 /* We do not handle data dependencies yet. */
3771 if (gfc_check_dependency (expr1
, matrix_a
, true)
3772 || gfc_check_dependency (expr1
, matrix_b
, true))
3776 if (matrix_a
->rank
== 2)
3780 if (matrix_b
->rank
== 2 && !transpose_b
)
3785 if (matrix_b
->rank
== 1)
3787 else /* matrix_b->rank == 2 */
3796 else /* matrix_a->rank == 1 */
3798 if (matrix_b
->rank
== 2)
3808 ns
= insert_block ();
3810 /* Assign the type of the zero expression for initializing the resulting
3811 array, and the expression (+ and * for real, integer and complex;
3812 .and. and .or for logical. */
3814 switch(expr1
->ts
.type
)
3817 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3818 op_times
= INTRINSIC_TIMES
;
3819 op_plus
= INTRINSIC_PLUS
;
3823 op_times
= INTRINSIC_AND
;
3824 op_plus
= INTRINSIC_OR
;
3825 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3829 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3831 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3832 op_times
= INTRINSIC_TIMES
;
3833 op_plus
= INTRINSIC_PLUS
;
3837 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3839 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3840 op_times
= INTRINSIC_TIMES
;
3841 op_plus
= INTRINSIC_PLUS
;
3849 current_code
= &ns
->code
;
3851 /* Freeze the references, keeping track of how many temporary variables were
3854 freeze_references (matrix_a
);
3855 freeze_references (matrix_b
);
3856 freeze_references (expr1
);
3859 next_code_point
= current_code
;
3862 next_code_point
= &ns
->code
;
3863 for (i
=0; i
<n_vars
; i
++)
3864 next_code_point
= &(*next_code_point
)->next
;
3867 /* Take care of the inline flag. If the limit check evaluates to a
3868 constant, dead code elimination will eliminate the unneeded branch. */
3870 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3872 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3874 /* Insert the original statement into the else branch. */
3875 if_limit
->block
->block
->next
= co
;
3878 /* ... and the new ones go into the original one. */
3879 *next_code_point
= if_limit
;
3880 next_code_point
= &if_limit
->block
->next
;
3883 assign_zero
= XCNEW (gfc_code
);
3884 assign_zero
->op
= EXEC_ASSIGN
;
3885 assign_zero
->loc
= co
->loc
;
3886 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3887 assign_zero
->expr2
= zero_e
;
3889 /* Handle the reallocation, if needed. */
3890 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3892 gfc_code
*lhs_alloc
;
3894 /* Only need to check a single dimension for the A2B2 case for
3895 bounds checking, the rest will be allocated. Also check this
3898 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3903 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3904 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3905 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3906 "in MATMUL intrinsic: Is %ld, should be %ld");
3907 *next_code_point
= test
;
3908 next_code_point
= &test
->next
;
3912 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3914 *next_code_point
= lhs_alloc
;
3915 next_code_point
= &lhs_alloc
->next
;
3918 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3921 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3923 if (m_case
== A2B2
|| m_case
== A2B1
)
3925 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3926 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3927 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3928 "in MATMUL intrinsic: Is %ld, should be %ld");
3929 *next_code_point
= test
;
3930 next_code_point
= &test
->next
;
3932 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3933 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3936 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3937 "MATMUL intrinsic for dimension 1: "
3938 "is %ld, should be %ld");
3939 else if (m_case
== A2B1
)
3940 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3941 "MATMUL intrinsic: "
3942 "is %ld, should be %ld");
3945 *next_code_point
= test
;
3946 next_code_point
= &test
->next
;
3948 else if (m_case
== A1B2
)
3950 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3951 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3952 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3953 "in MATMUL intrinsic: Is %ld, should be %ld");
3954 *next_code_point
= test
;
3955 next_code_point
= &test
->next
;
3957 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3958 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3960 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3961 "MATMUL intrinsic: "
3962 "is %ld, should be %ld");
3964 *next_code_point
= test
;
3965 next_code_point
= &test
->next
;
3970 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3971 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3972 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3973 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3975 *next_code_point
= test
;
3976 next_code_point
= &test
->next
;
3979 if (m_case
== A2B2T
)
3981 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3982 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3983 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3984 "MATMUL intrinsic for dimension 1: "
3985 "is %ld, should be %ld");
3987 *next_code_point
= test
;
3988 next_code_point
= &test
->next
;
3990 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3991 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3992 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3993 "MATMUL intrinsic for dimension 2: "
3994 "is %ld, should be %ld");
3995 *next_code_point
= test
;
3996 next_code_point
= &test
->next
;
3998 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3999 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4001 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
4002 "MATMUL intrnisic for dimension 2: "
4003 "is %ld, should be %ld");
4004 *next_code_point
= test
;
4005 next_code_point
= &test
->next
;
4009 if (m_case
== A2TB2
)
4011 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4012 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4014 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
4015 "MATMUL intrinsic for dimension 1: "
4016 "is %ld, should be %ld");
4018 *next_code_point
= test
;
4019 next_code_point
= &test
->next
;
4021 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4022 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4023 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4024 "MATMUL intrinsic for dimension 2: "
4025 "is %ld, should be %ld");
4026 *next_code_point
= test
;
4027 next_code_point
= &test
->next
;
4029 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4030 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4032 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
4033 "MATMUL intrnisic for dimension 2: "
4034 "is %ld, should be %ld");
4035 *next_code_point
= test
;
4036 next_code_point
= &test
->next
;
4041 *next_code_point
= assign_zero
;
4043 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4045 assign_matmul
= XCNEW (gfc_code
);
4046 assign_matmul
->op
= EXEC_ASSIGN
;
4047 assign_matmul
->loc
= co
->loc
;
4049 /* Get the bounds for the loops, create them and create the scalarized
4055 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4057 u1
= get_size_m1 (matrix_b
, 2);
4058 u2
= get_size_m1 (matrix_a
, 2);
4059 u3
= get_size_m1 (matrix_a
, 1);
4061 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4062 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4063 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4065 do_1
->block
->next
= do_2
;
4066 do_2
->block
->next
= do_3
;
4067 do_3
->block
->next
= assign_matmul
;
4069 var_1
= do_1
->ext
.iterator
->var
;
4070 var_2
= do_2
->ext
.iterator
->var
;
4071 var_3
= do_3
->ext
.iterator
->var
;
4075 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4079 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4083 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4088 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4090 u1
= get_size_m1 (matrix_b
, 1);
4091 u2
= get_size_m1 (matrix_a
, 2);
4092 u3
= get_size_m1 (matrix_a
, 1);
4094 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4095 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4096 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4098 do_1
->block
->next
= do_2
;
4099 do_2
->block
->next
= do_3
;
4100 do_3
->block
->next
= assign_matmul
;
4102 var_1
= do_1
->ext
.iterator
->var
;
4103 var_2
= do_2
->ext
.iterator
->var
;
4104 var_3
= do_3
->ext
.iterator
->var
;
4108 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4112 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4116 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4121 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4123 u1
= get_size_m1 (matrix_a
, 2);
4124 u2
= get_size_m1 (matrix_b
, 2);
4125 u3
= get_size_m1 (matrix_a
, 1);
4127 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4128 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4129 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4131 do_1
->block
->next
= do_2
;
4132 do_2
->block
->next
= do_3
;
4133 do_3
->block
->next
= assign_matmul
;
4135 var_1
= do_1
->ext
.iterator
->var
;
4136 var_2
= do_2
->ext
.iterator
->var
;
4137 var_3
= do_3
->ext
.iterator
->var
;
4141 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4145 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4149 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4154 u1
= get_size_m1 (matrix_b
, 1);
4155 u2
= get_size_m1 (matrix_a
, 1);
4157 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4158 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4160 do_1
->block
->next
= do_2
;
4161 do_2
->block
->next
= assign_matmul
;
4163 var_1
= do_1
->ext
.iterator
->var
;
4164 var_2
= do_2
->ext
.iterator
->var
;
4167 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4171 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4174 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4179 u1
= get_size_m1 (matrix_b
, 2);
4180 u2
= get_size_m1 (matrix_a
, 1);
4182 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4183 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4185 do_1
->block
->next
= do_2
;
4186 do_2
->block
->next
= assign_matmul
;
4188 var_1
= do_1
->ext
.iterator
->var
;
4189 var_2
= do_2
->ext
.iterator
->var
;
4192 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4195 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4199 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4207 /* Build the conjg call around the variables. Set the typespec manually
4208 because gfc_build_intrinsic_call sometimes gets this wrong. */
4213 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4214 matrix_a
->where
, 1, ascalar
);
4222 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4223 matrix_b
->where
, 1, bscalar
);
4226 /* First loop comes after the zero assignment. */
4227 assign_zero
->next
= do_1
;
4229 /* Build the assignment expression in the loop. */
4230 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4232 mult
= get_operand (op_times
, ascalar
, bscalar
);
4233 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4235 /* If we don't want to keep the original statement around in
4236 the else branch, we can free it. */
4238 if (if_limit
== NULL
)
4239 gfc_free_statements(co
);
4243 gfc_free_expr (zero
);
4249 /* Code for index interchange for loops which are grouped together in DO
4250 CONCURRENT or FORALL statements. This is currently only applied if the
4251 iterations are grouped together in a single statement.
4253 For this transformation, it is assumed that memory access in strides is
4254 expensive, and that loops which access later indices (which access memory
4255 in bigger strides) should be moved to the first loops.
4257 For this, a loop over all the statements is executed, counting the times
4258 that the loop iteration values are accessed in each index. The loop
4259 indices are then sorted to minimize access to later indices from inner
4262 /* Type for holding index information. */
4266 gfc_forall_iterator
*fa
;
4268 int n
[GFC_MAX_DIMENSIONS
];
4271 /* Callback function to determine if an expression is the
4272 corresponding variable. */
4275 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4277 gfc_expr
*expr
= *e
;
4280 if (expr
->expr_type
!= EXPR_VARIABLE
)
4283 sym
= (gfc_symbol
*) data
;
4284 return sym
== expr
->symtree
->n
.sym
;
4287 /* Callback function to calculate the cost of a certain index. */
4290 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4300 if (expr
->expr_type
!= EXPR_VARIABLE
)
4304 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4306 if (ref
->type
== REF_ARRAY
)
4312 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4315 ind
= (ind_type
*) data
;
4316 for (i
= 0; i
< ar
->dimen
; i
++)
4318 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4320 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4327 /* Callback function for qsort, to sort the loop indices. */
4330 loop_comp (const void *e1
, const void *e2
)
4332 const ind_type
*i1
= (const ind_type
*) e1
;
4333 const ind_type
*i2
= (const ind_type
*) e2
;
4336 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4338 if (i1
->n
[i
] != i2
->n
[i
])
4339 return i1
->n
[i
] - i2
->n
[i
];
4341 /* All other things being equal, let's not change the ordering. */
4342 return i2
->num
- i1
->num
;
4345 /* Main function to do the index interchange. */
4348 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4349 void *data ATTRIBUTE_UNUSED
)
4354 gfc_forall_iterator
*fa
;
4358 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4362 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4365 /* Nothing to reorder. */
4369 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4372 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4374 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4376 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4381 ind
[n_iter
].sym
= NULL
;
4382 ind
[n_iter
].fa
= NULL
;
4384 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4385 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4387 /* Do the actual index interchange. */
4388 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4389 for (i
=1; i
<n_iter
; i
++)
4391 fa
->next
= ind
[i
].fa
;
4396 if (flag_warn_frontend_loop_interchange
)
4398 for (i
=1; i
<n_iter
; i
++)
4400 if (ind
[i
-1].num
> ind
[i
].num
)
4402 gfc_warning (OPT_Wfrontend_loop_interchange
,
4403 "Interchanging loops at %L", &co
->loc
);
4412 #define WALK_SUBEXPR(NODE) \
4415 result = gfc_expr_walker (&(NODE), exprfn, data); \
4420 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4422 /* Walk expression *E, calling EXPRFN on each expression in it. */
4425 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4429 int walk_subtrees
= 1;
4430 gfc_actual_arglist
*a
;
4434 int result
= exprfn (e
, &walk_subtrees
, data
);
4438 switch ((*e
)->expr_type
)
4441 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4442 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4445 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4446 WALK_SUBEXPR (a
->expr
);
4450 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4451 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4452 WALK_SUBEXPR (a
->expr
);
4455 case EXPR_STRUCTURE
:
4457 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4458 c
= gfc_constructor_next (c
))
4460 if (c
->iterator
== NULL
)
4461 WALK_SUBEXPR (c
->expr
);
4465 WALK_SUBEXPR (c
->expr
);
4467 WALK_SUBEXPR (c
->iterator
->var
);
4468 WALK_SUBEXPR (c
->iterator
->start
);
4469 WALK_SUBEXPR (c
->iterator
->end
);
4470 WALK_SUBEXPR (c
->iterator
->step
);
4474 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4477 /* Fall through to the variable case in order to walk the
4481 case EXPR_SUBSTRING
:
4483 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4492 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4494 for (i
=0; i
< ar
->dimen
; i
++)
4496 WALK_SUBEXPR (ar
->start
[i
]);
4497 WALK_SUBEXPR (ar
->end
[i
]);
4498 WALK_SUBEXPR (ar
->stride
[i
]);
4505 WALK_SUBEXPR (r
->u
.ss
.start
);
4506 WALK_SUBEXPR (r
->u
.ss
.end
);
4522 #define WALK_SUBCODE(NODE) \
4525 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4531 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4532 on each expression in it. If any of the hooks returns non-zero, that
4533 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4534 no subcodes or subexpressions are traversed. */
4537 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4540 for (; *c
; c
= &(*c
)->next
)
4542 int walk_subtrees
= 1;
4543 int result
= codefn (c
, &walk_subtrees
, data
);
4550 gfc_actual_arglist
*a
;
4552 gfc_association_list
*alist
;
4553 bool saved_in_omp_workshare
;
4554 bool saved_in_where
;
4556 /* There might be statement insertions before the current code,
4557 which must not affect the expression walker. */
4560 saved_in_omp_workshare
= in_omp_workshare
;
4561 saved_in_where
= in_where
;
4567 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4568 if (co
->ext
.block
.assoc
)
4570 bool saved_in_assoc_list
= in_assoc_list
;
4572 in_assoc_list
= true;
4573 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4574 WALK_SUBEXPR (alist
->target
);
4576 in_assoc_list
= saved_in_assoc_list
;
4583 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4584 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4585 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4586 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4598 case EXEC_ASSIGN_CALL
:
4599 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4600 WALK_SUBEXPR (a
->expr
);
4604 WALK_SUBEXPR (co
->expr1
);
4605 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4606 WALK_SUBEXPR (a
->expr
);
4610 WALK_SUBEXPR (co
->expr1
);
4612 for (b
= co
->block
; b
; b
= b
->block
)
4615 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4617 WALK_SUBEXPR (cp
->low
);
4618 WALK_SUBEXPR (cp
->high
);
4620 WALK_SUBCODE (b
->next
);
4625 case EXEC_DEALLOCATE
:
4628 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4629 WALK_SUBEXPR (a
->expr
);
4634 case EXEC_DO_CONCURRENT
:
4636 gfc_forall_iterator
*fa
;
4637 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4639 WALK_SUBEXPR (fa
->var
);
4640 WALK_SUBEXPR (fa
->start
);
4641 WALK_SUBEXPR (fa
->end
);
4642 WALK_SUBEXPR (fa
->stride
);
4644 if (co
->op
== EXEC_FORALL
)
4650 WALK_SUBEXPR (co
->ext
.open
->unit
);
4651 WALK_SUBEXPR (co
->ext
.open
->file
);
4652 WALK_SUBEXPR (co
->ext
.open
->status
);
4653 WALK_SUBEXPR (co
->ext
.open
->access
);
4654 WALK_SUBEXPR (co
->ext
.open
->form
);
4655 WALK_SUBEXPR (co
->ext
.open
->recl
);
4656 WALK_SUBEXPR (co
->ext
.open
->blank
);
4657 WALK_SUBEXPR (co
->ext
.open
->position
);
4658 WALK_SUBEXPR (co
->ext
.open
->action
);
4659 WALK_SUBEXPR (co
->ext
.open
->delim
);
4660 WALK_SUBEXPR (co
->ext
.open
->pad
);
4661 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4662 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4663 WALK_SUBEXPR (co
->ext
.open
->convert
);
4664 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4665 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4666 WALK_SUBEXPR (co
->ext
.open
->round
);
4667 WALK_SUBEXPR (co
->ext
.open
->sign
);
4668 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4669 WALK_SUBEXPR (co
->ext
.open
->id
);
4670 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4671 WALK_SUBEXPR (co
->ext
.open
->share
);
4672 WALK_SUBEXPR (co
->ext
.open
->cc
);
4676 WALK_SUBEXPR (co
->ext
.close
->unit
);
4677 WALK_SUBEXPR (co
->ext
.close
->status
);
4678 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4679 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4682 case EXEC_BACKSPACE
:
4686 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4687 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4688 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4692 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4693 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4694 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4695 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4696 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4697 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4698 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4699 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4700 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4701 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4702 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4703 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4704 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4705 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4706 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4707 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4708 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4709 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4710 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4711 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4712 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4713 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4714 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4715 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4716 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4717 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4718 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4719 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4720 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4721 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4722 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4723 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4724 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4725 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4726 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4727 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4731 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4732 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4733 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4734 WALK_SUBEXPR (co
->ext
.wait
->id
);
4739 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4740 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4741 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4742 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4743 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4744 WALK_SUBEXPR (co
->ext
.dt
->size
);
4745 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4746 WALK_SUBEXPR (co
->ext
.dt
->id
);
4747 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4748 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4749 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4750 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4751 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4752 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4753 WALK_SUBEXPR (co
->ext
.dt
->round
);
4754 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4755 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4758 case EXEC_OMP_PARALLEL
:
4759 case EXEC_OMP_PARALLEL_DO
:
4760 case EXEC_OMP_PARALLEL_DO_SIMD
:
4761 case EXEC_OMP_PARALLEL_SECTIONS
:
4763 in_omp_workshare
= false;
4765 /* This goto serves as a shortcut to avoid code
4766 duplication or a larger if or switch statement. */
4767 goto check_omp_clauses
;
4769 case EXEC_OMP_WORKSHARE
:
4770 case EXEC_OMP_PARALLEL_WORKSHARE
:
4772 in_omp_workshare
= true;
4776 case EXEC_OMP_CRITICAL
:
4777 case EXEC_OMP_DISTRIBUTE
:
4778 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4779 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4780 case EXEC_OMP_DISTRIBUTE_SIMD
:
4782 case EXEC_OMP_DO_SIMD
:
4783 case EXEC_OMP_ORDERED
:
4784 case EXEC_OMP_SECTIONS
:
4785 case EXEC_OMP_SINGLE
:
4786 case EXEC_OMP_END_SINGLE
:
4788 case EXEC_OMP_TASKLOOP
:
4789 case EXEC_OMP_TASKLOOP_SIMD
:
4790 case EXEC_OMP_TARGET
:
4791 case EXEC_OMP_TARGET_DATA
:
4792 case EXEC_OMP_TARGET_ENTER_DATA
:
4793 case EXEC_OMP_TARGET_EXIT_DATA
:
4794 case EXEC_OMP_TARGET_PARALLEL
:
4795 case EXEC_OMP_TARGET_PARALLEL_DO
:
4796 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4797 case EXEC_OMP_TARGET_SIMD
:
4798 case EXEC_OMP_TARGET_TEAMS
:
4799 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4800 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4801 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4802 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4803 case EXEC_OMP_TARGET_UPDATE
:
4805 case EXEC_OMP_TEAMS
:
4806 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4807 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4808 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4809 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4811 /* Come to this label only from the
4812 EXEC_OMP_PARALLEL_* cases above. */
4816 if (co
->ext
.omp_clauses
)
4818 gfc_omp_namelist
*n
;
4819 static int list_types
[]
4820 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4821 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4823 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4824 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4825 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4826 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4827 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4828 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4829 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4830 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4831 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4832 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4833 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4834 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4835 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4836 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4837 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4838 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4840 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4842 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4844 WALK_SUBEXPR (n
->expr
);
4851 WALK_SUBEXPR (co
->expr1
);
4852 WALK_SUBEXPR (co
->expr2
);
4853 WALK_SUBEXPR (co
->expr3
);
4854 WALK_SUBEXPR (co
->expr4
);
4855 for (b
= co
->block
; b
; b
= b
->block
)
4857 WALK_SUBEXPR (b
->expr1
);
4858 WALK_SUBEXPR (b
->expr2
);
4859 WALK_SUBCODE (b
->next
);
4862 if (co
->op
== EXEC_FORALL
)
4865 if (co
->op
== EXEC_DO
)
4868 if (co
->op
== EXEC_IF
)
4871 if (co
->op
== EXEC_SELECT
)
4874 in_omp_workshare
= saved_in_omp_workshare
;
4875 in_where
= saved_in_where
;