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 *);
60 static bool is_fe_temp (gfc_expr
*e
);
63 static void check_locus (gfc_namespace
*);
66 /* How deep we are inside an argument list. */
68 static int count_arglist
;
70 /* Vector of gfc_expr ** we operate on. */
72 static vec
<gfc_expr
**> expr_array
;
74 /* Pointer to the gfc_code we currently work on - to be able to insert
75 a block before the statement. */
77 static gfc_code
**current_code
;
79 /* Pointer to the block to be inserted, and the statement we are
80 changing within the block. */
82 static gfc_code
*inserted_block
, **changed_statement
;
84 /* The namespace we are currently dealing with. */
86 static gfc_namespace
*current_ns
;
88 /* If we are within any forall loop. */
90 static int forall_level
;
92 /* Keep track of whether we are within an OMP workshare. */
94 static bool in_omp_workshare
;
96 /* Keep track of whether we are within a WHERE statement. */
100 /* Keep track of iterators for array constructors. */
102 static int iterator_level
;
104 /* Keep track of DO loop levels. */
112 static vec
<do_t
> doloop_list
;
113 static int doloop_level
;
115 /* Keep track of if and select case levels. */
118 static int select_level
;
120 /* Vector of gfc_expr * to keep track of DO loops. */
122 struct my_struct
*evec
;
124 /* Keep track of association lists. */
126 static bool in_assoc_list
;
128 /* Counter for temporary variables. */
130 static int var_num
= 1;
132 /* What sort of matrix we are dealing with when inlining MATMUL. */
134 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
136 /* Keep track of the number of expressions we have inserted so far
141 /* Entry point - run all passes for a namespace. */
144 gfc_run_passes (gfc_namespace
*ns
)
147 /* Warn about dubious DO loops where the index might
154 doloop_list
.release ();
161 gfc_get_errors (&w
, &e
);
165 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
166 optimize_namespace (ns
);
168 if (flag_frontend_optimize
)
170 optimize_reduction (ns
);
171 if (flag_dump_fortran_optimized
)
172 gfc_dump_parse_tree (ns
, stdout
);
174 expr_array
.release ();
177 if (flag_realloc_lhs
)
178 realloc_strings (ns
);
183 /* Callback function: Warn if there is no location information in a
187 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
188 void *data ATTRIBUTE_UNUSED
)
191 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
192 gfc_warning_internal (0, "No location in statement");
198 /* Callback function: Warn if there is no location information in an
202 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
203 void *data ATTRIBUTE_UNUSED
)
206 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
207 gfc_warning_internal (0, "No location in expression near %L",
208 &((*current_code
)->loc
));
212 /* Run check for missing location information. */
215 check_locus (gfc_namespace
*ns
)
217 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
219 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
221 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
228 /* Callback for each gfc_code node invoked from check_realloc_strings.
229 For an allocatable LHS string which also appears as a variable on
241 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
242 void *data ATTRIBUTE_UNUSED
)
244 gfc_expr
*expr1
, *expr2
;
250 if (co
->op
!= EXEC_ASSIGN
)
254 if (expr1
->ts
.type
!= BT_CHARACTER
255 || !gfc_expr_attr(expr1
).allocatable
256 || !expr1
->ts
.deferred
)
259 if (is_fe_temp (expr1
))
262 expr2
= gfc_discard_nops (co
->expr2
);
264 if (expr2
->expr_type
== EXPR_VARIABLE
)
266 found_substr
= false;
267 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
269 if (ref
->type
== REF_SUBSTRING
)
278 else if (expr2
->expr_type
!= EXPR_ARRAY
279 && (expr2
->expr_type
!= EXPR_OP
280 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
283 if (!gfc_check_dependency (expr1
, expr2
, true))
286 /* gfc_check_dependency doesn't always pick up identical expressions.
287 However, eliminating the above sends the compiler into an infinite
288 loop on valid expressions. Without this check, the gimplifier emits
289 an ICE for a = a, where a is deferred character length. */
290 if (!gfc_dep_compare_expr (expr1
, expr2
))
294 inserted_block
= NULL
;
295 changed_statement
= NULL
;
296 n
= create_var (expr2
, "realloc_string");
301 /* Callback for each gfc_code node invoked through gfc_code_walker
302 from optimize_namespace. */
305 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
306 void *data ATTRIBUTE_UNUSED
)
313 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
314 || op
== EXEC_CALL_PPC
)
320 inserted_block
= NULL
;
321 changed_statement
= NULL
;
323 if (op
== EXEC_ASSIGN
)
324 optimize_assignment (*c
);
328 /* Callback for each gfc_expr node invoked through gfc_code_walker
329 from optimize_namespace. */
332 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
333 void *data ATTRIBUTE_UNUSED
)
337 if ((*e
)->expr_type
== EXPR_FUNCTION
)
340 function_expr
= true;
343 function_expr
= false;
345 if (optimize_trim (*e
))
346 gfc_simplify_expr (*e
, 0);
348 if (optimize_lexical_comparison (*e
))
349 gfc_simplify_expr (*e
, 0);
351 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
352 gfc_simplify_expr (*e
, 0);
354 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
355 switch ((*e
)->value
.function
.isym
->id
)
357 case GFC_ISYM_MINLOC
:
358 case GFC_ISYM_MAXLOC
:
359 optimize_minmaxloc (e
);
371 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
372 function is a scalar, just copy it; otherwise returns the new element, the
373 old one can be freed. */
376 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
378 gfc_expr
*fcn
, *e
= c
->expr
;
380 fcn
= gfc_copy_expr (e
);
383 gfc_constructor_base newbase
;
385 gfc_constructor
*new_c
;
388 new_expr
= gfc_get_expr ();
389 new_expr
->expr_type
= EXPR_ARRAY
;
390 new_expr
->ts
= e
->ts
;
391 new_expr
->where
= e
->where
;
393 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
394 new_c
->iterator
= c
->iterator
;
395 new_expr
->value
.constructor
= newbase
;
403 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
405 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
406 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
407 fn
->value
.function
.isym
->name
,
408 fn
->where
, 3, fcn
, NULL
, NULL
);
409 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
410 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
411 fn
->value
.function
.isym
->name
,
412 fn
->where
, 2, fcn
, NULL
);
414 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
416 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
422 /* Callback function for optimzation of reductions to scalars. Transform ANY
423 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
424 correspondingly. Handly only the simple cases without MASK and DIM. */
427 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
428 void *data ATTRIBUTE_UNUSED
)
433 gfc_actual_arglist
*a
;
434 gfc_actual_arglist
*dim
;
436 gfc_expr
*res
, *new_expr
;
437 gfc_actual_arglist
*mask
;
441 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
442 || fn
->value
.function
.isym
== NULL
)
445 id
= fn
->value
.function
.isym
->id
;
447 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
448 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
451 a
= fn
->value
.function
.actual
;
453 /* Don't handle MASK or DIM. */
457 if (dim
->expr
!= NULL
)
460 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
463 if ( mask
->expr
!= NULL
)
469 if (arg
->expr_type
!= EXPR_ARRAY
)
478 case GFC_ISYM_PRODUCT
:
479 op
= INTRINSIC_TIMES
;
494 c
= gfc_constructor_first (arg
->value
.constructor
);
496 /* Don't do any simplififcation if we have
497 - no element in the constructor or
498 - only have a single element in the array which contains an
504 res
= copy_walk_reduction_arg (c
, fn
);
506 c
= gfc_constructor_next (c
);
509 new_expr
= gfc_get_expr ();
510 new_expr
->ts
= fn
->ts
;
511 new_expr
->expr_type
= EXPR_OP
;
512 new_expr
->rank
= fn
->rank
;
513 new_expr
->where
= fn
->where
;
514 new_expr
->value
.op
.op
= op
;
515 new_expr
->value
.op
.op1
= res
;
516 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
518 c
= gfc_constructor_next (c
);
521 gfc_simplify_expr (res
, 0);
528 /* Callback function for common function elimination, called from cfe_expr_0.
529 Put all eligible function expressions into expr_array. */
532 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
533 void *data ATTRIBUTE_UNUSED
)
536 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
539 /* We don't do character functions with unknown charlens. */
540 if ((*e
)->ts
.type
== BT_CHARACTER
541 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
542 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
545 /* We don't do function elimination within FORALL statements, it can
546 lead to wrong-code in certain circumstances. */
548 if (forall_level
> 0)
551 /* Function elimination inside an iterator could lead to functions which
552 depend on iterator variables being moved outside. FIXME: We should check
553 if the functions do indeed depend on the iterator variable. */
555 if (iterator_level
> 0)
558 /* If we don't know the shape at compile time, we create an allocatable
559 temporary variable to hold the intermediate result, but only if
560 allocation on assignment is active. */
562 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
565 /* Skip the test for pure functions if -faggressive-function-elimination
567 if ((*e
)->value
.function
.esym
)
569 /* Don't create an array temporary for elemental functions. */
570 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
573 /* Only eliminate potentially impure functions if the
574 user specifically requested it. */
575 if (!flag_aggressive_function_elimination
576 && !(*e
)->value
.function
.esym
->attr
.pure
577 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
581 if ((*e
)->value
.function
.isym
)
583 /* Conversions are handled on the fly by the middle end,
584 transpose during trans-* stages and TRANSFER by the middle end. */
585 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
586 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
587 || gfc_inline_intrinsic_function_p (*e
))
590 /* Don't create an array temporary for elemental functions,
591 as this would be wasteful of memory.
592 FIXME: Create a scalar temporary during scalarization. */
593 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
596 if (!(*e
)->value
.function
.isym
->pure
)
600 expr_array
.safe_push (e
);
604 /* Auxiliary function to check if an expression is a temporary created by
608 is_fe_temp (gfc_expr
*e
)
610 if (e
->expr_type
!= EXPR_VARIABLE
)
613 return e
->symtree
->n
.sym
->attr
.fe_temp
;
616 /* Determine the length of a string, if it can be evaluated as a constant
617 expression. Return a newly allocated gfc_expr or NULL on failure.
618 If the user specified a substring which is potentially longer than
619 the string itself, the string will be padded with spaces, which
623 constant_string_length (gfc_expr
*e
)
633 length
= e
->ts
.u
.cl
->length
;
634 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
635 return gfc_copy_expr(length
);
638 /* Return length of substring, if constant. */
639 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
641 if (ref
->type
== REF_SUBSTRING
642 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
644 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
647 mpz_add_ui (res
->value
.integer
, value
, 1);
653 /* Return length of char symbol, if constant. */
655 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
656 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
657 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
658 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
664 /* Insert a block at the current position unless it has already
665 been inserted; in this case use the one already there. */
667 static gfc_namespace
*
672 /* If the block hasn't already been created, do so. */
673 if (inserted_block
== NULL
)
675 inserted_block
= XCNEW (gfc_code
);
676 inserted_block
->op
= EXEC_BLOCK
;
677 inserted_block
->loc
= (*current_code
)->loc
;
678 ns
= gfc_build_block_ns (current_ns
);
679 inserted_block
->ext
.block
.ns
= ns
;
680 inserted_block
->ext
.block
.assoc
= NULL
;
682 ns
->code
= *current_code
;
684 /* If the statement has a label, make sure it is transferred to
685 the newly created block. */
687 if ((*current_code
)->here
)
689 inserted_block
->here
= (*current_code
)->here
;
690 (*current_code
)->here
= NULL
;
693 inserted_block
->next
= (*current_code
)->next
;
694 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
695 (*current_code
)->next
= NULL
;
696 /* Insert the BLOCK at the right position. */
697 *current_code
= inserted_block
;
698 ns
->parent
= current_ns
;
701 ns
= inserted_block
->ext
.block
.ns
;
706 /* Returns a new expression (a variable) to be used in place of the old one,
707 with an optional assignment statement before the current statement to set
708 the value of the variable. Creates a new BLOCK for the statement if that
709 hasn't already been done and puts the statement, plus the newly created
710 variables, in that block. Special cases: If the expression is constant or
711 a temporary which has already been created, just copy it. */
714 create_var (gfc_expr
* e
, const char *vname
)
716 char name
[GFC_MAX_SYMBOL_LEN
+1];
717 gfc_symtree
*symtree
;
725 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
726 return gfc_copy_expr (e
);
728 /* Creation of an array of unknown size requires realloc on assignment.
729 If that is not possible, just return NULL. */
730 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
733 ns
= insert_block ();
736 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
738 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
740 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
743 symbol
= symtree
->n
.sym
;
748 symbol
->as
= gfc_get_array_spec ();
749 symbol
->as
->rank
= e
->rank
;
751 if (e
->shape
== NULL
)
753 /* We don't know the shape at compile time, so we use an
755 symbol
->as
->type
= AS_DEFERRED
;
756 symbol
->attr
.allocatable
= 1;
760 symbol
->as
->type
= AS_EXPLICIT
;
761 /* Copy the shape. */
762 for (i
=0; i
<e
->rank
; i
++)
766 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
768 mpz_set_si (p
->value
.integer
, 1);
769 symbol
->as
->lower
[i
] = p
;
771 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
773 mpz_set (q
->value
.integer
, e
->shape
[i
]);
774 symbol
->as
->upper
[i
] = q
;
780 if (e
->ts
.type
== BT_CHARACTER
)
784 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
785 length
= constant_string_length (e
);
787 symbol
->ts
.u
.cl
->length
= length
;
790 symbol
->attr
.allocatable
= 1;
791 symbol
->ts
.u
.cl
->length
= NULL
;
792 symbol
->ts
.deferred
= 1;
797 symbol
->attr
.flavor
= FL_VARIABLE
;
798 symbol
->attr
.referenced
= 1;
799 symbol
->attr
.dimension
= e
->rank
> 0;
800 symbol
->attr
.fe_temp
= 1;
801 gfc_commit_symbol (symbol
);
803 result
= gfc_get_expr ();
804 result
->expr_type
= EXPR_VARIABLE
;
805 result
->ts
= symbol
->ts
;
806 result
->ts
.deferred
= deferred
;
807 result
->rank
= e
->rank
;
808 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
809 result
->symtree
= symtree
;
810 result
->where
= e
->where
;
813 result
->ref
= gfc_get_ref ();
814 result
->ref
->type
= REF_ARRAY
;
815 result
->ref
->u
.ar
.type
= AR_FULL
;
816 result
->ref
->u
.ar
.where
= e
->where
;
817 result
->ref
->u
.ar
.dimen
= e
->rank
;
818 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
819 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
820 if (warn_array_temporaries
)
821 gfc_warning (OPT_Warray_temporaries
,
822 "Creating array temporary at %L", &(e
->where
));
825 /* Generate the new assignment. */
826 n
= XCNEW (gfc_code
);
828 n
->loc
= (*current_code
)->loc
;
829 n
->next
= *changed_statement
;
830 n
->expr1
= gfc_copy_expr (result
);
832 *changed_statement
= n
;
838 /* Warn about function elimination. */
841 do_warn_function_elimination (gfc_expr
*e
)
844 if (e
->expr_type
== EXPR_FUNCTION
845 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
848 gfc_warning (OPT_Wfunction_elimination
,
849 "Removing call to impure function %qs at %L", name
,
852 gfc_warning (OPT_Wfunction_elimination
,
853 "Removing call to impure function at %L",
859 /* Callback function for the code walker for doing common function
860 elimination. This builds up the list of functions in the expression
861 and goes through them to detect duplicates, which it then replaces
865 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
866 void *data ATTRIBUTE_UNUSED
)
872 /* Don't do this optimization within OMP workshare or ASSOC lists. */
874 if (in_omp_workshare
|| in_assoc_list
)
880 expr_array
.release ();
882 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
884 /* Walk through all the functions. */
886 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
888 /* Skip if the function has been replaced by a variable already. */
889 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
896 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
899 newvar
= create_var (*ei
, "fcn");
901 if (warn_function_elimination
)
902 do_warn_function_elimination (*ej
);
905 *ej
= gfc_copy_expr (newvar
);
912 /* We did all the necessary walking in this function. */
917 /* Callback function for common function elimination, called from
918 gfc_code_walker. This keeps track of the current code, in order
919 to insert statements as needed. */
922 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
925 inserted_block
= NULL
;
926 changed_statement
= NULL
;
928 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
929 and allocation on assigment are prohibited inside WHERE, and finally
930 masking an expression would lead to wrong-code when replacing
933 b = sum(foo(a) + foo(a))
944 if ((*c
)->op
== EXEC_WHERE
)
954 /* Dummy function for expression call back, for use when we
955 really don't want to do any walking. */
958 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
959 void *data ATTRIBUTE_UNUSED
)
965 /* Dummy function for code callback, for use when we really
966 don't want to do anything. */
968 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
969 int *walk_subtrees ATTRIBUTE_UNUSED
,
970 void *data ATTRIBUTE_UNUSED
)
975 /* Code callback function for converting
982 This is because common function elimination would otherwise place the
983 temporary variables outside the loop. */
986 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
987 void *data ATTRIBUTE_UNUSED
)
990 gfc_code
*c_if1
, *c_if2
, *c_exit
;
992 gfc_expr
*e_not
, *e_cond
;
994 if (co
->op
!= EXEC_DO_WHILE
)
997 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1002 /* Generate the condition of the if statement, which is .not. the original
1004 e_not
= gfc_get_expr ();
1005 e_not
->ts
= e_cond
->ts
;
1006 e_not
->where
= e_cond
->where
;
1007 e_not
->expr_type
= EXPR_OP
;
1008 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1009 e_not
->value
.op
.op1
= e_cond
;
1011 /* Generate the EXIT statement. */
1012 c_exit
= XCNEW (gfc_code
);
1013 c_exit
->op
= EXEC_EXIT
;
1014 c_exit
->ext
.which_construct
= co
;
1015 c_exit
->loc
= co
->loc
;
1017 /* Generate the IF statement. */
1018 c_if2
= XCNEW (gfc_code
);
1019 c_if2
->op
= EXEC_IF
;
1020 c_if2
->expr1
= e_not
;
1021 c_if2
->next
= c_exit
;
1022 c_if2
->loc
= co
->loc
;
1024 /* ... plus the one to chain it to. */
1025 c_if1
= XCNEW (gfc_code
);
1026 c_if1
->op
= EXEC_IF
;
1027 c_if1
->block
= c_if2
;
1028 c_if1
->loc
= co
->loc
;
1030 /* Make the DO WHILE loop into a DO block by replacing the condition
1031 with a true constant. */
1032 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1034 /* Hang the generated if statement into the loop body. */
1036 loopblock
= co
->block
->next
;
1037 co
->block
->next
= c_if1
;
1038 c_if1
->next
= loopblock
;
1043 /* Code callback function for converting
1056 because otherwise common function elimination would place the BLOCKs
1057 into the wrong place. */
1060 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1061 void *data ATTRIBUTE_UNUSED
)
1064 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1066 if (co
->op
!= EXEC_IF
)
1069 /* This loop starts out with the first ELSE statement. */
1070 else_stmt
= co
->block
->block
;
1072 while (else_stmt
!= NULL
)
1074 gfc_code
*next_else
;
1076 /* If there is no condition, we're done. */
1077 if (else_stmt
->expr1
== NULL
)
1080 next_else
= else_stmt
->block
;
1082 /* Generate the new IF statement. */
1083 c_if2
= XCNEW (gfc_code
);
1084 c_if2
->op
= EXEC_IF
;
1085 c_if2
->expr1
= else_stmt
->expr1
;
1086 c_if2
->next
= else_stmt
->next
;
1087 c_if2
->loc
= else_stmt
->loc
;
1088 c_if2
->block
= next_else
;
1090 /* ... plus the one to chain it to. */
1091 c_if1
= XCNEW (gfc_code
);
1092 c_if1
->op
= EXEC_IF
;
1093 c_if1
->block
= c_if2
;
1094 c_if1
->loc
= else_stmt
->loc
;
1096 /* Insert the new IF after the ELSE. */
1097 else_stmt
->expr1
= NULL
;
1098 else_stmt
->next
= c_if1
;
1099 else_stmt
->block
= NULL
;
1101 else_stmt
= next_else
;
1103 /* Don't walk subtrees. */
1107 /* Callback function to var_in_expr - return true if expr1 and
1108 expr2 are identical variables. */
1110 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1113 gfc_expr
*expr1
= (gfc_expr
*) data
;
1114 gfc_expr
*expr2
= *e
;
1116 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1119 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1122 /* Return true if expr1 is found in expr2. */
1125 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1127 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1129 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1134 struct do_stack
*prev
;
1139 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1140 optimize by replacing do loops with their analog array slices. For
1143 write (*,*) (a(i), i=1,4)
1147 write (*,*) a(1:4:1) . */
1150 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1153 gfc_expr
*new_e
, *expr
, *start
;
1155 struct do_stack ds_push
;
1156 int i
, future_rank
= 0;
1157 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1160 /* Find the first transfer/do statement. */
1161 for (curr
= code
; curr
; curr
= curr
->next
)
1163 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1167 /* Ensure it is the only transfer/do statement because cases like
1169 write (*,*) (a(i), b(i), i=1,4)
1171 cannot be optimized. */
1173 if (!curr
|| curr
->next
)
1176 if (curr
->op
== EXEC_DO
)
1178 if (curr
->ext
.iterator
->var
->ref
)
1180 ds_push
.prev
= stack_top
;
1181 ds_push
.iter
= curr
->ext
.iterator
;
1182 ds_push
.code
= curr
;
1183 stack_top
= &ds_push
;
1184 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1186 if (curr
!= stack_top
->code
&& !*has_reached
)
1188 curr
->block
->next
= NULL
;
1189 gfc_free_statements (curr
);
1192 *has_reached
= true;
1198 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1202 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1205 /* Find the iterators belonging to each variable and check conditions. */
1206 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1208 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1209 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1212 start
= ref
->u
.ar
.start
[i
];
1213 gfc_simplify_expr (start
, 0);
1214 switch (start
->expr_type
)
1218 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1222 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1223 if (!stack_top
|| !stack_top
->iter
1224 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1226 /* Check for (a(i,i), i=1,3). */
1230 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1237 iters
[i
] = stack_top
->iter
;
1238 stack_top
= stack_top
->prev
;
1246 switch (start
->value
.op
.op
)
1248 case INTRINSIC_PLUS
:
1249 case INTRINSIC_TIMES
:
1250 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1251 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1253 case INTRINSIC_MINUS
:
1254 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1255 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1256 || start
->value
.op
.op1
->ref
)
1258 if (!stack_top
|| !stack_top
->iter
1259 || stack_top
->iter
->var
->symtree
1260 != start
->value
.op
.op1
->symtree
)
1262 iters
[i
] = stack_top
->iter
;
1263 stack_top
= stack_top
->prev
;
1275 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1276 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1280 gfc_expr
*var
= iters
[i
]->var
;
1281 for (int j
= i
- 1; j
< i
; j
++)
1284 && (var_in_expr (var
, iters
[j
]->start
)
1285 || var_in_expr (var
, iters
[j
]->end
)
1286 || var_in_expr (var
, iters
[j
]->step
)))
1292 /* Create new expr. */
1293 new_e
= gfc_copy_expr (curr
->expr1
);
1294 new_e
->expr_type
= EXPR_VARIABLE
;
1295 new_e
->rank
= future_rank
;
1296 if (curr
->expr1
->shape
)
1297 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1299 /* Assign new starts, ends and strides if necessary. */
1300 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1304 start
= ref
->u
.ar
.start
[i
];
1305 switch (start
->expr_type
)
1308 gfc_internal_error ("bad expression");
1311 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1312 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1313 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1314 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1315 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1316 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1319 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1320 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1321 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1322 expr
= gfc_copy_expr (start
);
1323 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1324 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1325 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1326 expr
= gfc_copy_expr (start
);
1327 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1328 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1329 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1330 switch (start
->value
.op
.op
)
1332 case INTRINSIC_MINUS
:
1333 case INTRINSIC_PLUS
:
1334 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1336 case INTRINSIC_TIMES
:
1337 expr
= gfc_copy_expr (start
);
1338 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1339 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1340 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1343 gfc_internal_error ("bad op");
1347 gfc_internal_error ("bad expression");
1350 curr
->expr1
= new_e
;
1352 /* Insert modified statement. Check whether the statement needs to be
1353 inserted at the lowest level. */
1354 if (!stack_top
->iter
)
1358 curr
->next
= prev
->next
->next
;
1363 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1364 stack_top
->code
->block
->next
= curr
;
1368 stack_top
->code
->block
->next
= curr
;
1372 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1373 tries to optimize its block. */
1376 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1377 void *data ATTRIBUTE_UNUSED
)
1379 gfc_code
**curr
, *prev
= NULL
;
1380 struct do_stack write
, first
;
1384 || ((*code
)->block
->op
!= EXEC_WRITE
1385 && (*code
)->block
->op
!= EXEC_READ
))
1393 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1395 if ((*curr
)->op
== EXEC_DO
)
1397 first
.prev
= &write
;
1398 first
.iter
= (*curr
)->ext
.iterator
;
1401 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1409 /* Optimize a namespace, including all contained namespaces.
1410 flag_frontend_optimize and flag_fronend_loop_interchange are
1411 handled separately. */
1414 optimize_namespace (gfc_namespace
*ns
)
1416 gfc_namespace
*saved_ns
= gfc_current_ns
;
1418 gfc_current_ns
= ns
;
1421 in_assoc_list
= false;
1422 in_omp_workshare
= false;
1424 if (flag_frontend_optimize
)
1426 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1427 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1428 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1429 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1430 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1431 if (flag_inline_matmul_limit
!= 0)
1437 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1442 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1444 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1449 if (flag_frontend_loop_interchange
)
1450 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1453 /* BLOCKs are handled in the expression walker below. */
1454 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1456 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1457 optimize_namespace (ns
);
1459 gfc_current_ns
= saved_ns
;
1462 /* Handle dependencies for allocatable strings which potentially redefine
1463 themselves in an assignment. */
1466 realloc_strings (gfc_namespace
*ns
)
1469 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1471 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1473 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1474 realloc_strings (ns
);
1480 optimize_reduction (gfc_namespace
*ns
)
1483 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1484 callback_reduction
, NULL
);
1486 /* BLOCKs are handled in the expression walker below. */
1487 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1489 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1490 optimize_reduction (ns
);
1494 /* Replace code like
1497 a = matmul(b,c) ; a = a + d
1498 where the array function is not elemental and not allocatable
1499 and does not depend on the left-hand side.
1503 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1511 if (e
->expr_type
== EXPR_OP
)
1513 switch (e
->value
.op
.op
)
1515 /* Unary operators and exponentiation: Only look at a single
1518 case INTRINSIC_UPLUS
:
1519 case INTRINSIC_UMINUS
:
1520 case INTRINSIC_PARENTHESES
:
1521 case INTRINSIC_POWER
:
1522 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1526 case INTRINSIC_CONCAT
:
1527 /* Do not do string concatenations. */
1531 /* Binary operators. */
1532 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1535 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1541 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1542 && ! (e
->value
.function
.esym
1543 && (e
->value
.function
.esym
->attr
.elemental
1544 || e
->value
.function
.esym
->attr
.allocatable
1545 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1546 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1547 && ! (e
->value
.function
.isym
1548 && (e
->value
.function
.isym
->elemental
1549 || e
->ts
.type
!= c
->expr1
->ts
.type
1550 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1551 && ! gfc_inline_intrinsic_function_p (e
))
1557 /* Insert a new assignment statement after the current one. */
1558 n
= XCNEW (gfc_code
);
1559 n
->op
= EXEC_ASSIGN
;
1564 n
->expr1
= gfc_copy_expr (c
->expr1
);
1565 n
->expr2
= c
->expr2
;
1566 new_expr
= gfc_copy_expr (c
->expr1
);
1574 /* Nothing to optimize. */
1578 /* Remove unneeded TRIMs at the end of expressions. */
1581 remove_trim (gfc_expr
*rhs
)
1589 /* Check for a // b // trim(c). Looping is probably not
1590 necessary because the parser usually generates
1591 (// (// a b ) trim(c) ) , but better safe than sorry. */
1593 while (rhs
->expr_type
== EXPR_OP
1594 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1595 rhs
= rhs
->value
.op
.op2
;
1597 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1598 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1600 strip_function_call (rhs
);
1601 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1609 /* Optimizations for an assignment. */
1612 optimize_assignment (gfc_code
* c
)
1614 gfc_expr
*lhs
, *rhs
;
1619 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1621 /* Optimize a = trim(b) to a = b. */
1624 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1625 if (is_empty_string (rhs
))
1626 rhs
->value
.character
.length
= 0;
1629 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1630 optimize_binop_array_assignment (c
, &rhs
, false);
1634 /* Remove an unneeded function call, modifying the expression.
1635 This replaces the function call with the value of its
1636 first argument. The rest of the argument list is freed. */
1639 strip_function_call (gfc_expr
*e
)
1642 gfc_actual_arglist
*a
;
1644 a
= e
->value
.function
.actual
;
1646 /* We should have at least one argument. */
1647 gcc_assert (a
->expr
!= NULL
);
1651 /* Free the remaining arglist, if any. */
1653 gfc_free_actual_arglist (a
->next
);
1655 /* Graft the argument expression onto the original function. */
1661 /* Optimization of lexical comparison functions. */
1664 optimize_lexical_comparison (gfc_expr
*e
)
1666 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1669 switch (e
->value
.function
.isym
->id
)
1672 return optimize_comparison (e
, INTRINSIC_LE
);
1675 return optimize_comparison (e
, INTRINSIC_GE
);
1678 return optimize_comparison (e
, INTRINSIC_GT
);
1681 return optimize_comparison (e
, INTRINSIC_LT
);
1689 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1690 do CHARACTER because of possible pessimization involving character
1694 combine_array_constructor (gfc_expr
*e
)
1697 gfc_expr
*op1
, *op2
;
1700 gfc_constructor
*c
, *new_c
;
1701 gfc_constructor_base oldbase
, newbase
;
1706 /* Array constructors have rank one. */
1710 /* Don't try to combine association lists, this makes no sense
1711 and leads to an ICE. */
1715 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1716 if (forall_level
> 0)
1719 /* Inside an iterator, things can get hairy; we are likely to create
1720 an invalid temporary variable. */
1721 if (iterator_level
> 0)
1724 op1
= e
->value
.op
.op1
;
1725 op2
= e
->value
.op
.op2
;
1730 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1731 scalar_first
= false;
1732 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1734 scalar_first
= true;
1735 op1
= e
->value
.op
.op2
;
1736 op2
= e
->value
.op
.op1
;
1741 if (op2
->ts
.type
== BT_CHARACTER
)
1744 /* This might be an expanded constructor with very many constant values. If
1745 we perform the operation here, we might end up with a long compile time
1746 and actually longer execution time, so a length bound is in order here.
1747 If the constructor constains something which is not a constant, it did
1748 not come from an expansion, so leave it alone. */
1750 #define CONSTR_LEN_MAX 4
1752 oldbase
= op1
->value
.constructor
;
1756 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1758 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1766 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1769 #undef CONSTR_LEN_MAX
1772 e
->expr_type
= EXPR_ARRAY
;
1774 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1776 for (c
= gfc_constructor_first (oldbase
); c
;
1777 c
= gfc_constructor_next (c
))
1779 new_expr
= gfc_get_expr ();
1780 new_expr
->ts
= e
->ts
;
1781 new_expr
->expr_type
= EXPR_OP
;
1782 new_expr
->rank
= c
->expr
->rank
;
1783 new_expr
->where
= c
->expr
->where
;
1784 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1788 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1789 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1793 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1794 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1797 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1798 new_c
->iterator
= c
->iterator
;
1802 gfc_free_expr (op1
);
1803 gfc_free_expr (op2
);
1804 gfc_free_expr (scalar
);
1806 e
->value
.constructor
= newbase
;
1810 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1811 2**k into ishift(1,k) */
1814 optimize_power (gfc_expr
*e
)
1816 gfc_expr
*op1
, *op2
;
1817 gfc_expr
*iand
, *ishft
;
1819 if (e
->ts
.type
!= BT_INTEGER
)
1822 op1
= e
->value
.op
.op1
;
1824 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1827 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1829 gfc_free_expr (op1
);
1831 op2
= e
->value
.op
.op2
;
1836 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1837 "_internal_iand", e
->where
, 2, op2
,
1838 gfc_get_int_expr (e
->ts
.kind
,
1841 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1842 "_internal_ishft", e
->where
, 2, iand
,
1843 gfc_get_int_expr (e
->ts
.kind
,
1846 e
->value
.op
.op
= INTRINSIC_MINUS
;
1847 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1848 e
->value
.op
.op2
= ishft
;
1851 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1853 gfc_free_expr (op1
);
1855 op2
= e
->value
.op
.op2
;
1859 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1860 "_internal_ishft", e
->where
, 2,
1861 gfc_get_int_expr (e
->ts
.kind
,
1868 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1870 op2
= e
->value
.op
.op2
;
1874 gfc_free_expr (op1
);
1875 gfc_free_expr (op2
);
1877 e
->expr_type
= EXPR_CONSTANT
;
1878 e
->value
.op
.op1
= NULL
;
1879 e
->value
.op
.op2
= NULL
;
1880 mpz_init_set_si (e
->value
.integer
, 1);
1881 /* Typespec and location are still OK. */
1888 /* Recursive optimization of operators. */
1891 optimize_op (gfc_expr
*e
)
1895 gfc_intrinsic_op op
= e
->value
.op
.op
;
1899 /* Only use new-style comparisons. */
1902 case INTRINSIC_EQ_OS
:
1906 case INTRINSIC_GE_OS
:
1910 case INTRINSIC_LE_OS
:
1914 case INTRINSIC_NE_OS
:
1918 case INTRINSIC_GT_OS
:
1922 case INTRINSIC_LT_OS
:
1938 changed
= optimize_comparison (e
, op
);
1941 /* Look at array constructors. */
1942 case INTRINSIC_PLUS
:
1943 case INTRINSIC_MINUS
:
1944 case INTRINSIC_TIMES
:
1945 case INTRINSIC_DIVIDE
:
1946 return combine_array_constructor (e
) || changed
;
1948 case INTRINSIC_POWER
:
1949 return optimize_power (e
);
1959 /* Return true if a constant string contains only blanks. */
1962 is_empty_string (gfc_expr
*e
)
1966 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1969 for (i
=0; i
< e
->value
.character
.length
; i
++)
1971 if (e
->value
.character
.string
[i
] != ' ')
1979 /* Insert a call to the intrinsic len_trim. Use a different name for
1980 the symbol tree so we don't run into trouble when the user has
1981 renamed len_trim for some reason. */
1984 get_len_trim_call (gfc_expr
*str
, int kind
)
1987 gfc_actual_arglist
*actual_arglist
, *next
;
1989 fcn
= gfc_get_expr ();
1990 fcn
->expr_type
= EXPR_FUNCTION
;
1991 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1992 actual_arglist
= gfc_get_actual_arglist ();
1993 actual_arglist
->expr
= str
;
1994 next
= gfc_get_actual_arglist ();
1995 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1996 actual_arglist
->next
= next
;
1998 fcn
->value
.function
.actual
= actual_arglist
;
1999 fcn
->where
= str
->where
;
2000 fcn
->ts
.type
= BT_INTEGER
;
2001 fcn
->ts
.kind
= gfc_charlen_int_kind
;
2003 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
2004 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
2005 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
2006 fcn
->symtree
->n
.sym
->attr
.function
= 1;
2007 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
2008 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
2009 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
2010 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
2015 /* Optimize expressions for equality. */
2018 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
2020 gfc_expr
*op1
, *op2
;
2024 gfc_actual_arglist
*firstarg
, *secondarg
;
2026 if (e
->expr_type
== EXPR_OP
)
2030 op1
= e
->value
.op
.op1
;
2031 op2
= e
->value
.op
.op2
;
2033 else if (e
->expr_type
== EXPR_FUNCTION
)
2035 /* One of the lexical comparison functions. */
2036 firstarg
= e
->value
.function
.actual
;
2037 secondarg
= firstarg
->next
;
2038 op1
= firstarg
->expr
;
2039 op2
= secondarg
->expr
;
2044 /* Strip off unneeded TRIM calls from string comparisons. */
2046 change
= remove_trim (op1
);
2048 if (remove_trim (op2
))
2051 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2052 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2053 handles them well). However, there are also cases that need a non-scalar
2054 argument. For example the any intrinsic. See PR 45380. */
2058 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2060 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2061 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2063 bool empty_op1
, empty_op2
;
2064 empty_op1
= is_empty_string (op1
);
2065 empty_op2
= is_empty_string (op2
);
2067 if (empty_op1
|| empty_op2
)
2073 /* This can only happen when an error for comparing
2074 characters of different kinds has already been issued. */
2075 if (empty_op1
&& empty_op2
)
2078 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2079 str
= empty_op1
? op2
: op1
;
2081 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2085 gfc_free_expr (op1
);
2087 gfc_free_expr (op2
);
2091 e
->value
.op
.op1
= fcn
;
2092 e
->value
.op
.op2
= zero
;
2097 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2099 if (flag_finite_math_only
2100 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2101 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2103 eq
= gfc_dep_compare_expr (op1
, op2
);
2106 /* Replace A // B < A // C with B < C, and A // B < C // B
2108 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2109 && op1
->expr_type
== EXPR_OP
2110 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2111 && op2
->expr_type
== EXPR_OP
2112 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2114 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2115 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2116 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2117 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2119 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2121 /* Watch out for 'A ' // x vs. 'A' // x. */
2123 if (op1_left
->expr_type
== EXPR_CONSTANT
2124 && op2_left
->expr_type
== EXPR_CONSTANT
2125 && op1_left
->value
.character
.length
2126 != op2_left
->value
.character
.length
)
2134 firstarg
->expr
= op1_right
;
2135 secondarg
->expr
= op2_right
;
2139 e
->value
.op
.op1
= op1_right
;
2140 e
->value
.op
.op2
= op2_right
;
2142 optimize_comparison (e
, op
);
2146 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2152 firstarg
->expr
= op1_left
;
2153 secondarg
->expr
= op2_left
;
2157 e
->value
.op
.op1
= op1_left
;
2158 e
->value
.op
.op2
= op2_left
;
2161 optimize_comparison (e
, op
);
2168 /* eq can only be -1, 0 or 1 at this point. */
2196 gfc_internal_error ("illegal OP in optimize_comparison");
2200 /* Replace the expression by a constant expression. The typespec
2201 and where remains the way it is. */
2204 e
->expr_type
= EXPR_CONSTANT
;
2205 e
->value
.logical
= result
;
2213 /* Optimize a trim function by replacing it with an equivalent substring
2214 involving a call to len_trim. This only works for expressions where
2215 variables are trimmed. Return true if anything was modified. */
2218 optimize_trim (gfc_expr
*e
)
2223 gfc_ref
**rr
= NULL
;
2225 /* Don't do this optimization within an argument list, because
2226 otherwise aliasing issues may occur. */
2228 if (count_arglist
!= 1)
2231 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2232 || e
->value
.function
.isym
== NULL
2233 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2236 a
= e
->value
.function
.actual
->expr
;
2238 if (a
->expr_type
!= EXPR_VARIABLE
)
2241 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2243 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2246 /* Follow all references to find the correct place to put the newly
2247 created reference. FIXME: Also handle substring references and
2248 array references. Array references cause strange regressions at
2253 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2255 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2260 strip_function_call (e
);
2265 /* Create the reference. */
2267 ref
= gfc_get_ref ();
2268 ref
->type
= REF_SUBSTRING
;
2270 /* Set the start of the reference. */
2272 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2274 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2276 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2278 /* Set the end of the reference to the call to len_trim. */
2280 ref
->u
.ss
.end
= fcn
;
2281 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2286 /* Optimize minloc(b), where b is rank 1 array, into
2287 (/ minloc(b, dim=1) /), and similarly for maxloc,
2288 as the latter forms are expanded inline. */
2291 optimize_minmaxloc (gfc_expr
**e
)
2294 gfc_actual_arglist
*a
;
2298 || fn
->value
.function
.actual
== NULL
2299 || fn
->value
.function
.actual
->expr
== NULL
2300 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2303 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2304 (*e
)->shape
= fn
->shape
;
2307 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2309 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2310 strcpy (name
, fn
->value
.function
.name
);
2311 p
= strstr (name
, "loc0");
2313 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2314 if (fn
->value
.function
.actual
->next
)
2316 a
= fn
->value
.function
.actual
->next
;
2317 gcc_assert (a
->expr
== NULL
);
2321 a
= gfc_get_actual_arglist ();
2322 fn
->value
.function
.actual
->next
= a
;
2324 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2326 mpz_set_ui (a
->expr
->value
.integer
, 1);
2329 /* Callback function for code checking that we do not pass a DO variable to an
2330 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2333 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2334 void *data ATTRIBUTE_UNUSED
)
2338 gfc_formal_arglist
*f
;
2339 gfc_actual_arglist
*a
;
2346 /* If the doloop_list grew, we have to truncate it here. */
2348 if ((unsigned) doloop_level
< doloop_list
.length())
2349 doloop_list
.truncate (doloop_level
);
2356 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2361 loop
.branch_level
= if_level
+ select_level
;
2362 loop
.seen_goto
= false;
2363 doloop_list
.safe_push (loop
);
2366 /* If anything could transfer control away from a suspicious
2367 subscript, make sure to set seen_goto in the current DO loop
2372 case EXEC_ERROR_STOP
:
2378 if (co
->ext
.open
->err
)
2383 if (co
->ext
.close
->err
)
2387 case EXEC_BACKSPACE
:
2392 if (co
->ext
.filepos
->err
)
2397 if (co
->ext
.filepos
->err
)
2403 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2408 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2409 loop
.seen_goto
= true;
2414 if (co
->resolved_sym
== NULL
)
2417 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2419 /* Withot a formal arglist, there is only unknown INTENT,
2420 which we don't check for. */
2428 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2436 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2438 if (a
->expr
&& a
->expr
->symtree
2439 && a
->expr
->symtree
->n
.sym
== do_sym
)
2441 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2442 gfc_error_now ("Variable %qs at %L set to undefined "
2443 "value inside loop beginning at %L as "
2444 "INTENT(OUT) argument to subroutine %qs",
2445 do_sym
->name
, &a
->expr
->where
,
2446 &(doloop_list
[i
].c
->loc
),
2447 co
->symtree
->n
.sym
->name
);
2448 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2449 gfc_error_now ("Variable %qs at %L not definable inside "
2450 "loop beginning at %L as INTENT(INOUT) "
2451 "argument to subroutine %qs",
2452 do_sym
->name
, &a
->expr
->where
,
2453 &(doloop_list
[i
].c
->loc
),
2454 co
->symtree
->n
.sym
->name
);
2465 if (seen_goto
&& doloop_level
> 0)
2466 doloop_list
[doloop_level
-1].seen_goto
= true;
2471 /* Callback function to warn about different things within DO loops. */
2474 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2475 void *data ATTRIBUTE_UNUSED
)
2479 if (doloop_list
.length () == 0)
2482 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2485 last
= &doloop_list
.last();
2486 if (last
->seen_goto
&& !warn_do_subscript
)
2489 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2501 /* Callback function - if the expression is the variable in data->sym,
2502 replace it with a constant from data->val. */
2505 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2512 if (ex
->expr_type
!= EXPR_VARIABLE
)
2515 d
= (insert_index_t
*) data
;
2516 if (ex
->symtree
->n
.sym
!= d
->sym
)
2519 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2520 mpz_set (n
->value
.integer
, d
->val
);
2527 /* In the expression e, replace occurrences of the variable sym with
2528 val. If this results in a constant expression, return true and
2529 return the value in ret. Return false if the expression already
2530 is a constant. Caller has to clear ret in that case. */
2533 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2536 insert_index_t data
;
2539 if (e
->expr_type
== EXPR_CONSTANT
)
2542 n
= gfc_copy_expr (e
);
2544 mpz_init_set (data
.val
, val
);
2545 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2546 gfc_simplify_expr (n
, 0);
2548 if (n
->expr_type
== EXPR_CONSTANT
)
2551 mpz_init_set (ret
, n
->value
.integer
);
2556 mpz_clear (data
.val
);
2562 /* Check array subscripts for possible out-of-bounds accesses in DO
2563 loops with constant bounds. */
2566 do_subscript (gfc_expr
**e
)
2576 /* Constants are already checked. */
2577 if (v
->expr_type
== EXPR_CONSTANT
)
2580 /* Wrong warnings will be generated in an associate list. */
2584 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2586 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2589 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2592 mpz_t do_start
, do_step
, do_end
;
2593 bool have_do_start
, have_do_end
;
2594 bool error_not_proven
;
2601 /* If we are within a branch, or a goto or equivalent
2602 was seen in the DO loop before, then we cannot prove that
2603 this expression is actually evaluated. Don't do anything
2604 unless we want to see it all. */
2605 error_not_proven
= lp
->seen_goto
2606 || lp
->branch_level
< if_level
+ select_level
;
2608 if (error_not_proven
&& !warn_do_subscript
)
2611 if (error_not_proven
)
2612 warn
= OPT_Wdo_subscript
;
2616 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2617 if (do_sym
->ts
.type
!= BT_INTEGER
)
2620 /* If we do not know about the stepsize, the loop may be zero trip.
2621 Do not warn in this case. */
2623 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2624 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2628 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2630 have_do_start
= true;
2631 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2634 have_do_start
= false;
2637 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2640 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2643 have_do_end
= false;
2645 if (!have_do_start
&& !have_do_end
)
2648 /* May have to correct the end value if the step does not equal
2650 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2656 mpz_sub (diff
, do_end
, do_start
);
2657 mpz_tdiv_r (rem
, diff
, do_step
);
2658 mpz_sub (do_end
, do_end
, rem
);
2663 for (i
= 0; i
< ar
->dimen
; i
++)
2666 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2667 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2669 if (ar
->as
->lower
[i
]
2670 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2671 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2672 gfc_warning (warn
, "Array reference at %L out of bounds "
2673 "(%ld < %ld) in loop beginning at %L",
2674 &ar
->start
[i
]->where
, mpz_get_si (val
),
2675 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2676 &doloop_list
[j
].c
->loc
);
2678 if (ar
->as
->upper
[i
]
2679 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2680 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2681 gfc_warning (warn
, "Array reference at %L out of bounds "
2682 "(%ld > %ld) in loop beginning at %L",
2683 &ar
->start
[i
]->where
, mpz_get_si (val
),
2684 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2685 &doloop_list
[j
].c
->loc
);
2690 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2691 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2693 if (ar
->as
->lower
[i
]
2694 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2695 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2696 gfc_warning (warn
, "Array reference at %L out of bounds "
2697 "(%ld < %ld) in loop beginning at %L",
2698 &ar
->start
[i
]->where
, mpz_get_si (val
),
2699 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2700 &doloop_list
[j
].c
->loc
);
2702 if (ar
->as
->upper
[i
]
2703 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2704 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2705 gfc_warning (warn
, "Array reference at %L out of bounds "
2706 "(%ld > %ld) in loop beginning at %L",
2707 &ar
->start
[i
]->where
, mpz_get_si (val
),
2708 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2709 &doloop_list
[j
].c
->loc
);
2719 /* Function for functions checking that we do not pass a DO variable
2720 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2723 do_intent (gfc_expr
**e
)
2725 gfc_formal_arglist
*f
;
2726 gfc_actual_arglist
*a
;
2733 if (expr
->expr_type
!= EXPR_FUNCTION
)
2736 /* Intrinsic functions don't modify their arguments. */
2738 if (expr
->value
.function
.isym
)
2741 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2743 /* Without a formal arglist, there is only unknown INTENT,
2744 which we don't check for. */
2748 a
= expr
->value
.function
.actual
;
2752 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2759 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2761 if (a
->expr
&& a
->expr
->symtree
2762 && a
->expr
->symtree
->n
.sym
== do_sym
)
2764 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2765 gfc_error_now ("Variable %qs at %L set to undefined value "
2766 "inside loop beginning at %L as INTENT(OUT) "
2767 "argument to function %qs", do_sym
->name
,
2768 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2769 expr
->symtree
->n
.sym
->name
);
2770 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2771 gfc_error_now ("Variable %qs at %L not definable inside loop"
2772 " beginning at %L as INTENT(INOUT) argument to"
2773 " function %qs", do_sym
->name
,
2774 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2775 expr
->symtree
->n
.sym
->name
);
2786 doloop_warn (gfc_namespace
*ns
)
2788 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2791 /* This selction deals with inlining calls to MATMUL. */
2793 /* Replace calls to matmul outside of straight assignments with a temporary
2794 variable so that later inlining will work. */
2797 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2801 bool *found
= (bool *) data
;
2805 if (e
->expr_type
!= EXPR_FUNCTION
2806 || e
->value
.function
.isym
== NULL
2807 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2810 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2811 || in_where
|| in_assoc_list
)
2814 /* Check if this is already in the form c = matmul(a,b). */
2816 if ((*current_code
)->expr2
== e
)
2819 n
= create_var (e
, "matmul");
2821 /* If create_var is unable to create a variable (for example if
2822 -fno-realloc-lhs is in force with a variable that does not have bounds
2823 known at compile-time), just return. */
2833 /* Set current_code and associated variables so that matmul_to_var_expr can
2837 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2838 void *data ATTRIBUTE_UNUSED
)
2840 if (current_code
!= c
)
2843 inserted_block
= NULL
;
2844 changed_statement
= NULL
;
2851 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2852 for a and b if there is a dependency between the arguments and the
2853 result variable or if a or b are the result of calculations that cannot
2854 be handled by the inliner. */
2857 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2858 void *data ATTRIBUTE_UNUSED
)
2860 gfc_expr
*expr1
, *expr2
;
2862 gfc_actual_arglist
*a
, *b
;
2864 gfc_expr
*matrix_a
, *matrix_b
;
2865 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2869 if (co
->op
!= EXEC_ASSIGN
)
2872 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2876 /* This has some duplication with inline_matmul_assign. This
2877 is because the creation of temporary variables could still fail,
2878 and inline_matmul_assign still needs to be able to handle these
2883 if (expr2
->expr_type
!= EXPR_FUNCTION
2884 || expr2
->value
.function
.isym
== NULL
2885 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2889 a
= expr2
->value
.function
.actual
;
2890 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2891 if (matrix_a
!= NULL
)
2893 if (matrix_a
->expr_type
== EXPR_VARIABLE
2894 && (gfc_check_dependency (matrix_a
, expr1
, true)
2895 || has_dimen_vector_ref (matrix_a
)))
2903 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2904 if (matrix_b
!= NULL
)
2906 if (matrix_b
->expr_type
== EXPR_VARIABLE
2907 && (gfc_check_dependency (matrix_b
, expr1
, true)
2908 || has_dimen_vector_ref (matrix_b
)))
2914 if (!a_tmp
&& !b_tmp
)
2918 inserted_block
= NULL
;
2919 changed_statement
= NULL
;
2923 at
= create_var (a
->expr
,"mma");
2930 bt
= create_var (b
->expr
,"mmb");
2937 /* Auxiliary function to build and simplify an array inquiry function.
2938 dim is zero-based. */
2941 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2944 gfc_expr
*dim_arg
, *kind
;
2950 case GFC_ISYM_LBOUND
:
2951 name
= "_gfortran_lbound";
2954 case GFC_ISYM_UBOUND
:
2955 name
= "_gfortran_ubound";
2959 name
= "_gfortran_size";
2966 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2967 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2968 gfc_index_integer_kind
);
2970 ec
= gfc_copy_expr (e
);
2972 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2974 ec
->no_bounds_check
= 1;
2975 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2977 gfc_simplify_expr (fcn
, 0);
2978 fcn
->no_bounds_check
= 1;
2982 /* Builds a logical expression. */
2985 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2990 ts
.type
= BT_LOGICAL
;
2991 ts
.kind
= gfc_default_logical_kind
;
2992 res
= gfc_get_expr ();
2993 res
->where
= e1
->where
;
2994 res
->expr_type
= EXPR_OP
;
2995 res
->value
.op
.op
= op
;
2996 res
->value
.op
.op1
= e1
;
2997 res
->value
.op
.op2
= e2
;
3004 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3005 compatible typespecs. */
3008 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3012 res
= gfc_get_expr ();
3014 res
->where
= e1
->where
;
3015 res
->expr_type
= EXPR_OP
;
3016 res
->value
.op
.op
= op
;
3017 res
->value
.op
.op1
= e1
;
3018 res
->value
.op
.op2
= e2
;
3019 gfc_simplify_expr (res
, 0);
3023 /* Generate the IF statement for a runtime check if we want to do inlining or
3024 not - putting in the code for both branches and putting it into the syntax
3025 tree is the caller's responsibility. For fixed array sizes, this should be
3026 removed by DCE. Only called for rank-two matrices A and B. */
3029 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
3031 gfc_expr
*inline_limit
;
3032 gfc_code
*if_1
, *if_2
, *else_2
;
3033 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3037 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
3039 /* Calculation is done in real to avoid integer overflow. */
3041 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3043 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
3045 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3048 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3049 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3050 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3054 ts
.kind
= gfc_default_real_kind
;
3055 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3056 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3057 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3059 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3060 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3062 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3063 gfc_simplify_expr (cond
, 0);
3065 else_2
= XCNEW (gfc_code
);
3066 else_2
->op
= EXEC_IF
;
3067 else_2
->loc
= a
->where
;
3069 if_2
= XCNEW (gfc_code
);
3072 if_2
->loc
= a
->where
;
3073 if_2
->block
= else_2
;
3075 if_1
= XCNEW (gfc_code
);
3078 if_1
->loc
= a
->where
;
3084 /* Insert code to issue a runtime error if the expressions are not equal. */
3087 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3090 gfc_code
*if_1
, *if_2
;
3092 gfc_actual_arglist
*a1
, *a2
, *a3
;
3094 gcc_assert (e1
->where
.lb
);
3095 /* Build the call to runtime_error. */
3096 c
= XCNEW (gfc_code
);
3100 /* Get a null-terminated message string. */
3102 a1
= gfc_get_actual_arglist ();
3103 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3104 msg
, strlen(msg
)+1);
3107 /* Pass the value of the first expression. */
3108 a2
= gfc_get_actual_arglist ();
3109 a2
->expr
= gfc_copy_expr (e1
);
3112 /* Pass the value of the second expression. */
3113 a3
= gfc_get_actual_arglist ();
3114 a3
->expr
= gfc_copy_expr (e2
);
3117 gfc_check_fe_runtime_error (c
->ext
.actual
);
3118 gfc_resolve_fe_runtime_error (c
);
3120 if_2
= XCNEW (gfc_code
);
3122 if_2
->loc
= e1
->where
;
3125 if_1
= XCNEW (gfc_code
);
3128 if_1
->loc
= e1
->where
;
3130 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3131 gfc_simplify_expr (cond
, 0);
3137 /* Handle matrix reallocation. Caller is responsible to insert into
3140 For the two-dimensional case, build
3142 if (allocated(c)) then
3143 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3145 allocate (c(size(a,1), size(b,2)))
3148 allocate (c(size(a,1),size(b,2)))
3151 and for the other cases correspondingly.
3155 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3156 enum matrix_case m_case
)
3159 gfc_expr
*allocated
, *alloc_expr
;
3160 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3161 gfc_code
*else_alloc
;
3162 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3164 gfc_expr
*cond
, *ne1
, *ne2
;
3166 if (warn_realloc_lhs
)
3167 gfc_warning (OPT_Wrealloc_lhs
,
3168 "Code for reallocating the allocatable array at %L will "
3169 "be added", &c
->where
);
3171 alloc_expr
= gfc_copy_expr (c
);
3173 ar
= gfc_find_array_ref (alloc_expr
);
3174 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3176 /* c comes in as a full ref. Change it into a copy and make it into an
3177 element ref so it has the right form for for ALLOCATE. In the same
3178 switch statement, also generate the size comparison for the secod IF
3181 ar
->type
= AR_ELEMENT
;
3186 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3187 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3188 ne1
= build_logical_expr (INTRINSIC_NE
,
3189 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3190 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3191 ne2
= build_logical_expr (INTRINSIC_NE
,
3192 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3193 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3194 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3198 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3199 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3201 ne1
= build_logical_expr (INTRINSIC_NE
,
3202 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3203 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3204 ne2
= build_logical_expr (INTRINSIC_NE
,
3205 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3206 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3207 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3212 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3213 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3215 ne1
= build_logical_expr (INTRINSIC_NE
,
3216 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3217 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3218 ne2
= build_logical_expr (INTRINSIC_NE
,
3219 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3220 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3221 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3225 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3226 cond
= build_logical_expr (INTRINSIC_NE
,
3227 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3228 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3232 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3233 cond
= build_logical_expr (INTRINSIC_NE
,
3234 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3235 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3243 gfc_simplify_expr (cond
, 0);
3245 /* We need two identical allocate statements in two
3246 branches of the IF statement. */
3248 allocate1
= XCNEW (gfc_code
);
3249 allocate1
->op
= EXEC_ALLOCATE
;
3250 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3251 allocate1
->loc
= c
->where
;
3252 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3254 allocate_else
= XCNEW (gfc_code
);
3255 allocate_else
->op
= EXEC_ALLOCATE
;
3256 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3257 allocate_else
->loc
= c
->where
;
3258 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3260 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3261 "_gfortran_allocated", c
->where
,
3262 1, gfc_copy_expr (c
));
3264 deallocate
= XCNEW (gfc_code
);
3265 deallocate
->op
= EXEC_DEALLOCATE
;
3266 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3267 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3268 deallocate
->next
= allocate1
;
3269 deallocate
->loc
= c
->where
;
3271 if_size_2
= XCNEW (gfc_code
);
3272 if_size_2
->op
= EXEC_IF
;
3273 if_size_2
->expr1
= cond
;
3274 if_size_2
->loc
= c
->where
;
3275 if_size_2
->next
= deallocate
;
3277 if_size_1
= XCNEW (gfc_code
);
3278 if_size_1
->op
= EXEC_IF
;
3279 if_size_1
->block
= if_size_2
;
3280 if_size_1
->loc
= c
->where
;
3282 else_alloc
= XCNEW (gfc_code
);
3283 else_alloc
->op
= EXEC_IF
;
3284 else_alloc
->loc
= c
->where
;
3285 else_alloc
->next
= allocate_else
;
3287 if_alloc_2
= XCNEW (gfc_code
);
3288 if_alloc_2
->op
= EXEC_IF
;
3289 if_alloc_2
->expr1
= allocated
;
3290 if_alloc_2
->loc
= c
->where
;
3291 if_alloc_2
->next
= if_size_1
;
3292 if_alloc_2
->block
= else_alloc
;
3294 if_alloc_1
= XCNEW (gfc_code
);
3295 if_alloc_1
->op
= EXEC_IF
;
3296 if_alloc_1
->block
= if_alloc_2
;
3297 if_alloc_1
->loc
= c
->where
;
3302 /* Callback function for has_function_or_op. */
3305 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3306 void *data ATTRIBUTE_UNUSED
)
3311 return (*e
)->expr_type
== EXPR_FUNCTION
3312 || (*e
)->expr_type
== EXPR_OP
;
3315 /* Returns true if the expression contains a function. */
3318 has_function_or_op (gfc_expr
**e
)
3323 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3326 /* Freeze (assign to a temporary variable) a single expression. */
3329 freeze_expr (gfc_expr
**ep
)
3332 if (has_function_or_op (ep
))
3334 ne
= create_var (*ep
, "freeze");
3339 /* Go through an expression's references and assign them to temporary
3340 variables if they contain functions. This is usually done prior to
3341 front-end scalarization to avoid multiple invocations of functions. */
3344 freeze_references (gfc_expr
*e
)
3350 for (r
=e
->ref
; r
; r
=r
->next
)
3352 if (r
->type
== REF_SUBSTRING
)
3354 if (r
->u
.ss
.start
!= NULL
)
3355 freeze_expr (&r
->u
.ss
.start
);
3357 if (r
->u
.ss
.end
!= NULL
)
3358 freeze_expr (&r
->u
.ss
.end
);
3360 else if (r
->type
== REF_ARRAY
)
3369 for (i
=0; i
<ar
->dimen
; i
++)
3371 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3373 freeze_expr (&ar
->start
[i
]);
3374 freeze_expr (&ar
->end
[i
]);
3375 freeze_expr (&ar
->stride
[i
]);
3377 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3379 freeze_expr (&ar
->start
[i
]);
3385 for (i
=0; i
<ar
->dimen
; i
++)
3386 freeze_expr (&ar
->start
[i
]);
3396 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3399 convert_to_index_kind (gfc_expr
*e
)
3403 gcc_assert (e
!= NULL
);
3405 res
= gfc_copy_expr (e
);
3407 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3409 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3413 ts
.type
= BT_INTEGER
;
3414 ts
.kind
= gfc_index_integer_kind
;
3416 gfc_convert_type_warn (e
, &ts
, 2, 0);
3422 /* Function to create a DO loop including creation of the
3423 iteration variable. gfc_expr are copied.*/
3426 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3427 gfc_namespace
*ns
, char *vname
)
3430 char name
[GFC_MAX_SYMBOL_LEN
+1];
3431 gfc_symtree
*symtree
;
3436 /* Create an expression for the iteration variable. */
3438 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3440 sprintf (name
, "__var_%d_do", var_num
++);
3443 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3446 /* Create the loop variable. */
3448 symbol
= symtree
->n
.sym
;
3449 symbol
->ts
.type
= BT_INTEGER
;
3450 symbol
->ts
.kind
= gfc_index_integer_kind
;
3451 symbol
->attr
.flavor
= FL_VARIABLE
;
3452 symbol
->attr
.referenced
= 1;
3453 symbol
->attr
.dimension
= 0;
3454 symbol
->attr
.fe_temp
= 1;
3455 gfc_commit_symbol (symbol
);
3457 i
= gfc_get_expr ();
3458 i
->expr_type
= EXPR_VARIABLE
;
3462 i
->symtree
= symtree
;
3464 /* ... and the nested DO statements. */
3465 n
= XCNEW (gfc_code
);
3468 n
->ext
.iterator
= gfc_get_iterator ();
3469 n
->ext
.iterator
->var
= i
;
3470 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3471 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3473 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3475 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3478 n2
= XCNEW (gfc_code
);
3486 /* Get the upper bound of the DO loops for matmul along a dimension. This
3490 get_size_m1 (gfc_expr
*e
, int dimen
)
3495 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3497 res
= gfc_get_constant_expr (BT_INTEGER
,
3498 gfc_index_integer_kind
, &e
->where
);
3499 mpz_sub_ui (res
->value
.integer
, size
, 1);
3504 res
= get_operand (INTRINSIC_MINUS
,
3505 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3506 gfc_get_int_expr (gfc_index_integer_kind
,
3508 gfc_simplify_expr (res
, 0);
3514 /* Function to return a scalarized expression. It is assumed that indices are
3515 zero based to make generation of DO loops easier. A zero as index will
3516 access the first element along a dimension. Single element references will
3517 be skipped. A NULL as an expression will be replaced by a full reference.
3518 This assumes that the index loops have gfc_index_integer_kind, and that all
3519 references have been frozen. */
3522 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3531 e
= gfc_copy_expr(e_in
);
3535 ar
= gfc_find_array_ref (e
);
3537 /* We scalarize count_index variables, reducing the rank by count_index. */
3539 e
->rank
= rank
- count_index
;
3541 was_fullref
= ar
->type
== AR_FULL
;
3544 ar
->type
= AR_ELEMENT
;
3546 ar
->type
= AR_SECTION
;
3548 /* Loop over the indices. For each index, create the expression
3549 index * stride + lbound(e, dim). */
3552 for (i
=0; i
< ar
->dimen
; i
++)
3554 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3556 if (index
[i_index
] != NULL
)
3558 gfc_expr
*lbound
, *nindex
;
3561 loopvar
= gfc_copy_expr (index
[i_index
]);
3567 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3568 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3572 ts
.type
= BT_INTEGER
;
3573 ts
.kind
= gfc_index_integer_kind
;
3574 gfc_convert_type (tmp
, &ts
, 2);
3576 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3581 /* Calculate the lower bound of the expression. */
3584 lbound
= gfc_copy_expr (ar
->start
[i
]);
3585 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3589 ts
.type
= BT_INTEGER
;
3590 ts
.kind
= gfc_index_integer_kind
;
3591 gfc_convert_type (lbound
, &ts
, 2);
3600 lbound_e
= gfc_copy_expr (e_in
);
3602 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3603 if (ref
->type
== REF_ARRAY
3604 && (ref
->u
.ar
.type
== AR_FULL
3605 || ref
->u
.ar
.type
== AR_SECTION
))
3610 gfc_free_ref_list (ref
->next
);
3616 /* Look at full individual sections, like a(:). The first index
3617 is the lbound of a full ref. */
3624 /* For assumed size, we need to keep around the final
3625 reference in order not to get an error on resolution
3626 below, and we cannot use AR_FULL. */
3628 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3630 ar
->type
= AR_SECTION
;
3639 for (j
= 0; j
< to
; j
++)
3641 gfc_free_expr (ar
->start
[j
]);
3642 ar
->start
[j
] = NULL
;
3643 gfc_free_expr (ar
->end
[j
]);
3645 gfc_free_expr (ar
->stride
[j
]);
3646 ar
->stride
[j
] = NULL
;
3649 /* We have to get rid of the shape, if there is one. Do
3650 so by freeing it and calling gfc_resolve to rebuild
3651 it, if necessary. */
3653 if (lbound_e
->shape
)
3654 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3656 lbound_e
->rank
= ar
->dimen
;
3657 gfc_resolve_expr (lbound_e
);
3659 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3661 gfc_free_expr (lbound_e
);
3664 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3666 gfc_free_expr (ar
->start
[i
]);
3667 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3669 gfc_free_expr (ar
->end
[i
]);
3671 gfc_free_expr (ar
->stride
[i
]);
3672 ar
->stride
[i
] = NULL
;
3673 gfc_simplify_expr (ar
->start
[i
], 0);
3675 else if (was_fullref
)
3677 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3683 /* Bounds checking will be done before the loops if -fcheck=bounds
3685 e
->no_bounds_check
= 1;
3689 /* Helper function to check for a dimen vector as subscript. */
3692 has_dimen_vector_ref (gfc_expr
*e
)
3697 ar
= gfc_find_array_ref (e
);
3699 if (ar
->type
== AR_FULL
)
3702 for (i
=0; i
<ar
->dimen
; i
++)
3703 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3709 /* If handed an expression of the form
3713 check if A can be handled by matmul and return if there is an uneven number
3714 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3715 otherwise. The caller has to check for the correct rank. */
3718 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3725 if (e
->expr_type
== EXPR_VARIABLE
)
3727 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3730 else if (e
->expr_type
== EXPR_FUNCTION
)
3732 if (e
->value
.function
.isym
== NULL
)
3735 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3737 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3738 *transpose
= !*transpose
;
3744 e
= e
->value
.function
.actual
->expr
;
3751 /* Macros for unified error messages. */
3753 #define B_ERROR(n) _("Incorrect extent in argument B in MATMUL intrinsic in " \
3754 "dimension " #n ": is %ld, should be %ld")
3756 #define C_ERROR(n) _("Array bound mismatch for dimension " #n " of array " \
3760 /* Inline assignments of the form c = matmul(a,b).
3761 Handle only the cases currently where b and c are rank-two arrays.
3763 This basically translates the code to
3769 do k=0, size(a, 2)-1
3770 do i=0, size(a, 1)-1
3771 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3772 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3773 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3774 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3783 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3784 void *data ATTRIBUTE_UNUSED
)
3787 gfc_expr
*expr1
, *expr2
;
3788 gfc_expr
*matrix_a
, *matrix_b
;
3789 gfc_actual_arglist
*a
, *b
;
3790 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3792 gfc_expr
*u1
, *u2
, *u3
;
3794 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3796 gfc_expr
*var_1
, *var_2
, *var_3
;
3799 gfc_intrinsic_op op_times
, op_plus
;
3800 enum matrix_case m_case
;
3802 gfc_code
*if_limit
= NULL
;
3803 gfc_code
**next_code_point
;
3804 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3807 if (co
->op
!= EXEC_ASSIGN
)
3810 if (in_where
|| in_assoc_list
)
3813 /* The BLOCKS generated for the temporary variables and FORALL don't
3815 if (forall_level
> 0)
3818 /* For now don't do anything in OpenMP workshare, it confuses
3819 its translation, which expects only the allowed statements in there.
3820 We should figure out how to parallelize this eventually. */
3821 if (in_omp_workshare
)
3826 if (expr2
->expr_type
!= EXPR_FUNCTION
3827 || expr2
->value
.function
.isym
== NULL
3828 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3832 inserted_block
= NULL
;
3833 changed_statement
= NULL
;
3835 a
= expr2
->value
.function
.actual
;
3836 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3837 if (matrix_a
== NULL
)
3841 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3842 if (matrix_b
== NULL
)
3845 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3846 || has_dimen_vector_ref (matrix_b
))
3849 /* We do not handle data dependencies yet. */
3850 if (gfc_check_dependency (expr1
, matrix_a
, true)
3851 || gfc_check_dependency (expr1
, matrix_b
, true))
3855 if (matrix_a
->rank
== 2)
3859 if (matrix_b
->rank
== 2 && !transpose_b
)
3864 if (matrix_b
->rank
== 1)
3866 else /* matrix_b->rank == 2 */
3875 else /* matrix_a->rank == 1 */
3877 if (matrix_b
->rank
== 2)
3887 ns
= insert_block ();
3889 /* Assign the type of the zero expression for initializing the resulting
3890 array, and the expression (+ and * for real, integer and complex;
3891 .and. and .or for logical. */
3893 switch(expr1
->ts
.type
)
3896 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3897 op_times
= INTRINSIC_TIMES
;
3898 op_plus
= INTRINSIC_PLUS
;
3902 op_times
= INTRINSIC_AND
;
3903 op_plus
= INTRINSIC_OR
;
3904 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3908 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3910 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3911 op_times
= INTRINSIC_TIMES
;
3912 op_plus
= INTRINSIC_PLUS
;
3916 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3918 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3919 op_times
= INTRINSIC_TIMES
;
3920 op_plus
= INTRINSIC_PLUS
;
3928 current_code
= &ns
->code
;
3930 /* Freeze the references, keeping track of how many temporary variables were
3933 freeze_references (matrix_a
);
3934 freeze_references (matrix_b
);
3935 freeze_references (expr1
);
3938 next_code_point
= current_code
;
3941 next_code_point
= &ns
->code
;
3942 for (i
=0; i
<n_vars
; i
++)
3943 next_code_point
= &(*next_code_point
)->next
;
3946 /* Take care of the inline flag. If the limit check evaluates to a
3947 constant, dead code elimination will eliminate the unneeded branch. */
3949 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3951 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3953 /* Insert the original statement into the else branch. */
3954 if_limit
->block
->block
->next
= co
;
3957 /* ... and the new ones go into the original one. */
3958 *next_code_point
= if_limit
;
3959 next_code_point
= &if_limit
->block
->next
;
3962 zero_e
->no_bounds_check
= 1;
3964 assign_zero
= XCNEW (gfc_code
);
3965 assign_zero
->op
= EXEC_ASSIGN
;
3966 assign_zero
->loc
= co
->loc
;
3967 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3968 assign_zero
->expr1
->no_bounds_check
= 1;
3969 assign_zero
->expr2
= zero_e
;
3971 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
3973 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3976 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3982 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3983 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3984 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
3985 *next_code_point
= test
;
3986 next_code_point
= &test
->next
;
3990 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3991 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3992 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
3993 *next_code_point
= test
;
3994 next_code_point
= &test
->next
;
4000 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4001 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4002 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4003 *next_code_point
= test
;
4004 next_code_point
= &test
->next
;
4008 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4009 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4010 test
= runtime_error_ne (c1
, b2
, C_ERROR(1));
4011 *next_code_point
= test
;
4012 next_code_point
= &test
->next
;
4018 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4019 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4020 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4021 *next_code_point
= test
;
4022 next_code_point
= &test
->next
;
4026 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4027 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4028 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4029 *next_code_point
= test
;
4030 next_code_point
= &test
->next
;
4032 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4033 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4034 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4035 *next_code_point
= test
;
4036 next_code_point
= &test
->next
;
4042 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4043 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4044 /* matrix_b is transposed, hence dimension 1 for the error message. */
4045 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4046 *next_code_point
= test
;
4047 next_code_point
= &test
->next
;
4051 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4052 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4053 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4054 *next_code_point
= test
;
4055 next_code_point
= &test
->next
;
4057 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4058 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4059 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4060 *next_code_point
= test
;
4061 next_code_point
= &test
->next
;
4067 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4068 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4069 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4070 *next_code_point
= test
;
4071 next_code_point
= &test
->next
;
4075 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4076 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4077 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4078 *next_code_point
= test
;
4079 next_code_point
= &test
->next
;
4081 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4082 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4083 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4084 *next_code_point
= test
;
4085 next_code_point
= &test
->next
;
4094 /* Handle the reallocation, if needed. */
4098 gfc_code
*lhs_alloc
;
4100 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4102 *next_code_point
= lhs_alloc
;
4103 next_code_point
= &lhs_alloc
->next
;
4107 *next_code_point
= assign_zero
;
4109 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4111 assign_matmul
= XCNEW (gfc_code
);
4112 assign_matmul
->op
= EXEC_ASSIGN
;
4113 assign_matmul
->loc
= co
->loc
;
4115 /* Get the bounds for the loops, create them and create the scalarized
4121 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4123 u1
= get_size_m1 (matrix_b
, 2);
4124 u2
= get_size_m1 (matrix_a
, 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 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4156 u1
= get_size_m1 (matrix_b
, 1);
4157 u2
= get_size_m1 (matrix_a
, 2);
4158 u3
= get_size_m1 (matrix_a
, 1);
4160 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4161 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4162 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4164 do_1
->block
->next
= do_2
;
4165 do_2
->block
->next
= do_3
;
4166 do_3
->block
->next
= assign_matmul
;
4168 var_1
= do_1
->ext
.iterator
->var
;
4169 var_2
= do_2
->ext
.iterator
->var
;
4170 var_3
= do_3
->ext
.iterator
->var
;
4174 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4178 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4182 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4187 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4189 u1
= get_size_m1 (matrix_a
, 2);
4190 u2
= get_size_m1 (matrix_b
, 2);
4191 u3
= get_size_m1 (matrix_a
, 1);
4193 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4194 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4195 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4197 do_1
->block
->next
= do_2
;
4198 do_2
->block
->next
= do_3
;
4199 do_3
->block
->next
= assign_matmul
;
4201 var_1
= do_1
->ext
.iterator
->var
;
4202 var_2
= do_2
->ext
.iterator
->var
;
4203 var_3
= do_3
->ext
.iterator
->var
;
4207 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4211 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4215 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4220 u1
= get_size_m1 (matrix_b
, 1);
4221 u2
= get_size_m1 (matrix_a
, 1);
4223 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4224 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4226 do_1
->block
->next
= do_2
;
4227 do_2
->block
->next
= assign_matmul
;
4229 var_1
= do_1
->ext
.iterator
->var
;
4230 var_2
= do_2
->ext
.iterator
->var
;
4233 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4237 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4240 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4245 u1
= get_size_m1 (matrix_b
, 2);
4246 u2
= get_size_m1 (matrix_a
, 1);
4248 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4249 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4251 do_1
->block
->next
= do_2
;
4252 do_2
->block
->next
= assign_matmul
;
4254 var_1
= do_1
->ext
.iterator
->var
;
4255 var_2
= do_2
->ext
.iterator
->var
;
4258 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4261 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4265 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4273 /* Build the conjg call around the variables. Set the typespec manually
4274 because gfc_build_intrinsic_call sometimes gets this wrong. */
4279 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4280 matrix_a
->where
, 1, ascalar
);
4288 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4289 matrix_b
->where
, 1, bscalar
);
4292 /* First loop comes after the zero assignment. */
4293 assign_zero
->next
= do_1
;
4295 /* Build the assignment expression in the loop. */
4296 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4298 mult
= get_operand (op_times
, ascalar
, bscalar
);
4299 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4301 /* If we don't want to keep the original statement around in
4302 the else branch, we can free it. */
4304 if (if_limit
== NULL
)
4305 gfc_free_statements(co
);
4309 gfc_free_expr (zero
);
4315 /* Code for index interchange for loops which are grouped together in DO
4316 CONCURRENT or FORALL statements. This is currently only applied if the
4317 iterations are grouped together in a single statement.
4319 For this transformation, it is assumed that memory access in strides is
4320 expensive, and that loops which access later indices (which access memory
4321 in bigger strides) should be moved to the first loops.
4323 For this, a loop over all the statements is executed, counting the times
4324 that the loop iteration values are accessed in each index. The loop
4325 indices are then sorted to minimize access to later indices from inner
4328 /* Type for holding index information. */
4332 gfc_forall_iterator
*fa
;
4334 int n
[GFC_MAX_DIMENSIONS
];
4337 /* Callback function to determine if an expression is the
4338 corresponding variable. */
4341 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4343 gfc_expr
*expr
= *e
;
4346 if (expr
->expr_type
!= EXPR_VARIABLE
)
4349 sym
= (gfc_symbol
*) data
;
4350 return sym
== expr
->symtree
->n
.sym
;
4353 /* Callback function to calculate the cost of a certain index. */
4356 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4366 if (expr
->expr_type
!= EXPR_VARIABLE
)
4370 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4372 if (ref
->type
== REF_ARRAY
)
4378 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4381 ind
= (ind_type
*) data
;
4382 for (i
= 0; i
< ar
->dimen
; i
++)
4384 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4386 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4393 /* Callback function for qsort, to sort the loop indices. */
4396 loop_comp (const void *e1
, const void *e2
)
4398 const ind_type
*i1
= (const ind_type
*) e1
;
4399 const ind_type
*i2
= (const ind_type
*) e2
;
4402 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4404 if (i1
->n
[i
] != i2
->n
[i
])
4405 return i1
->n
[i
] - i2
->n
[i
];
4407 /* All other things being equal, let's not change the ordering. */
4408 return i2
->num
- i1
->num
;
4411 /* Main function to do the index interchange. */
4414 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4415 void *data ATTRIBUTE_UNUSED
)
4420 gfc_forall_iterator
*fa
;
4424 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4428 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4431 /* Nothing to reorder. */
4435 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4438 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4440 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4442 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4447 ind
[n_iter
].sym
= NULL
;
4448 ind
[n_iter
].fa
= NULL
;
4450 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4451 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4453 /* Do the actual index interchange. */
4454 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4455 for (i
=1; i
<n_iter
; i
++)
4457 fa
->next
= ind
[i
].fa
;
4462 if (flag_warn_frontend_loop_interchange
)
4464 for (i
=1; i
<n_iter
; i
++)
4466 if (ind
[i
-1].num
> ind
[i
].num
)
4468 gfc_warning (OPT_Wfrontend_loop_interchange
,
4469 "Interchanging loops at %L", &co
->loc
);
4478 #define WALK_SUBEXPR(NODE) \
4481 result = gfc_expr_walker (&(NODE), exprfn, data); \
4486 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4488 /* Walk expression *E, calling EXPRFN on each expression in it. */
4491 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4495 int walk_subtrees
= 1;
4496 gfc_actual_arglist
*a
;
4500 int result
= exprfn (e
, &walk_subtrees
, data
);
4504 switch ((*e
)->expr_type
)
4507 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4508 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4511 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4512 WALK_SUBEXPR (a
->expr
);
4516 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4517 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4518 WALK_SUBEXPR (a
->expr
);
4521 case EXPR_STRUCTURE
:
4523 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4524 c
= gfc_constructor_next (c
))
4526 if (c
->iterator
== NULL
)
4527 WALK_SUBEXPR (c
->expr
);
4531 WALK_SUBEXPR (c
->expr
);
4533 WALK_SUBEXPR (c
->iterator
->var
);
4534 WALK_SUBEXPR (c
->iterator
->start
);
4535 WALK_SUBEXPR (c
->iterator
->end
);
4536 WALK_SUBEXPR (c
->iterator
->step
);
4540 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4543 /* Fall through to the variable case in order to walk the
4547 case EXPR_SUBSTRING
:
4549 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4558 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4560 for (i
=0; i
< ar
->dimen
; i
++)
4562 WALK_SUBEXPR (ar
->start
[i
]);
4563 WALK_SUBEXPR (ar
->end
[i
]);
4564 WALK_SUBEXPR (ar
->stride
[i
]);
4571 WALK_SUBEXPR (r
->u
.ss
.start
);
4572 WALK_SUBEXPR (r
->u
.ss
.end
);
4588 #define WALK_SUBCODE(NODE) \
4591 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4597 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4598 on each expression in it. If any of the hooks returns non-zero, that
4599 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4600 no subcodes or subexpressions are traversed. */
4603 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4606 for (; *c
; c
= &(*c
)->next
)
4608 int walk_subtrees
= 1;
4609 int result
= codefn (c
, &walk_subtrees
, data
);
4616 gfc_actual_arglist
*a
;
4618 gfc_association_list
*alist
;
4619 bool saved_in_omp_workshare
;
4620 bool saved_in_where
;
4622 /* There might be statement insertions before the current code,
4623 which must not affect the expression walker. */
4626 saved_in_omp_workshare
= in_omp_workshare
;
4627 saved_in_where
= in_where
;
4633 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4634 if (co
->ext
.block
.assoc
)
4636 bool saved_in_assoc_list
= in_assoc_list
;
4638 in_assoc_list
= true;
4639 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4640 WALK_SUBEXPR (alist
->target
);
4642 in_assoc_list
= saved_in_assoc_list
;
4649 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4650 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4651 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4652 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4664 case EXEC_ASSIGN_CALL
:
4665 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4666 WALK_SUBEXPR (a
->expr
);
4670 WALK_SUBEXPR (co
->expr1
);
4671 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4672 WALK_SUBEXPR (a
->expr
);
4676 WALK_SUBEXPR (co
->expr1
);
4678 for (b
= co
->block
; b
; b
= b
->block
)
4681 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4683 WALK_SUBEXPR (cp
->low
);
4684 WALK_SUBEXPR (cp
->high
);
4686 WALK_SUBCODE (b
->next
);
4691 case EXEC_DEALLOCATE
:
4694 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4695 WALK_SUBEXPR (a
->expr
);
4700 case EXEC_DO_CONCURRENT
:
4702 gfc_forall_iterator
*fa
;
4703 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4705 WALK_SUBEXPR (fa
->var
);
4706 WALK_SUBEXPR (fa
->start
);
4707 WALK_SUBEXPR (fa
->end
);
4708 WALK_SUBEXPR (fa
->stride
);
4710 if (co
->op
== EXEC_FORALL
)
4716 WALK_SUBEXPR (co
->ext
.open
->unit
);
4717 WALK_SUBEXPR (co
->ext
.open
->file
);
4718 WALK_SUBEXPR (co
->ext
.open
->status
);
4719 WALK_SUBEXPR (co
->ext
.open
->access
);
4720 WALK_SUBEXPR (co
->ext
.open
->form
);
4721 WALK_SUBEXPR (co
->ext
.open
->recl
);
4722 WALK_SUBEXPR (co
->ext
.open
->blank
);
4723 WALK_SUBEXPR (co
->ext
.open
->position
);
4724 WALK_SUBEXPR (co
->ext
.open
->action
);
4725 WALK_SUBEXPR (co
->ext
.open
->delim
);
4726 WALK_SUBEXPR (co
->ext
.open
->pad
);
4727 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4728 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4729 WALK_SUBEXPR (co
->ext
.open
->convert
);
4730 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4731 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4732 WALK_SUBEXPR (co
->ext
.open
->round
);
4733 WALK_SUBEXPR (co
->ext
.open
->sign
);
4734 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4735 WALK_SUBEXPR (co
->ext
.open
->id
);
4736 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4737 WALK_SUBEXPR (co
->ext
.open
->share
);
4738 WALK_SUBEXPR (co
->ext
.open
->cc
);
4742 WALK_SUBEXPR (co
->ext
.close
->unit
);
4743 WALK_SUBEXPR (co
->ext
.close
->status
);
4744 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4745 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4748 case EXEC_BACKSPACE
:
4752 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4753 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4754 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4758 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4759 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4760 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4761 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4762 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4763 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4764 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4765 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4766 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4767 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4768 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4769 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4770 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4771 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4772 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4773 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4774 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4775 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4776 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4777 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4778 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4779 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4780 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4781 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4782 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4783 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4784 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4785 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4786 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4787 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4788 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4789 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4790 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4791 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4792 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4793 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4797 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4798 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4799 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4800 WALK_SUBEXPR (co
->ext
.wait
->id
);
4805 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4806 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4807 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4808 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4809 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4810 WALK_SUBEXPR (co
->ext
.dt
->size
);
4811 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4812 WALK_SUBEXPR (co
->ext
.dt
->id
);
4813 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4814 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4815 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4816 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4817 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4818 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4819 WALK_SUBEXPR (co
->ext
.dt
->round
);
4820 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4821 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4824 case EXEC_OMP_PARALLEL
:
4825 case EXEC_OMP_PARALLEL_DO
:
4826 case EXEC_OMP_PARALLEL_DO_SIMD
:
4827 case EXEC_OMP_PARALLEL_SECTIONS
:
4829 in_omp_workshare
= false;
4831 /* This goto serves as a shortcut to avoid code
4832 duplication or a larger if or switch statement. */
4833 goto check_omp_clauses
;
4835 case EXEC_OMP_WORKSHARE
:
4836 case EXEC_OMP_PARALLEL_WORKSHARE
:
4838 in_omp_workshare
= true;
4842 case EXEC_OMP_CRITICAL
:
4843 case EXEC_OMP_DISTRIBUTE
:
4844 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4845 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4846 case EXEC_OMP_DISTRIBUTE_SIMD
:
4848 case EXEC_OMP_DO_SIMD
:
4849 case EXEC_OMP_ORDERED
:
4850 case EXEC_OMP_SECTIONS
:
4851 case EXEC_OMP_SINGLE
:
4852 case EXEC_OMP_END_SINGLE
:
4854 case EXEC_OMP_TASKLOOP
:
4855 case EXEC_OMP_TASKLOOP_SIMD
:
4856 case EXEC_OMP_TARGET
:
4857 case EXEC_OMP_TARGET_DATA
:
4858 case EXEC_OMP_TARGET_ENTER_DATA
:
4859 case EXEC_OMP_TARGET_EXIT_DATA
:
4860 case EXEC_OMP_TARGET_PARALLEL
:
4861 case EXEC_OMP_TARGET_PARALLEL_DO
:
4862 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4863 case EXEC_OMP_TARGET_SIMD
:
4864 case EXEC_OMP_TARGET_TEAMS
:
4865 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4866 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4867 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4868 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4869 case EXEC_OMP_TARGET_UPDATE
:
4871 case EXEC_OMP_TEAMS
:
4872 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4873 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4874 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4875 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4877 /* Come to this label only from the
4878 EXEC_OMP_PARALLEL_* cases above. */
4882 if (co
->ext
.omp_clauses
)
4884 gfc_omp_namelist
*n
;
4885 static int list_types
[]
4886 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4887 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4889 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4890 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4891 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4892 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4893 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4894 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4895 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4896 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4897 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4898 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4899 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4900 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4901 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4902 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4903 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4904 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4906 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4908 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4910 WALK_SUBEXPR (n
->expr
);
4917 WALK_SUBEXPR (co
->expr1
);
4918 WALK_SUBEXPR (co
->expr2
);
4919 WALK_SUBEXPR (co
->expr3
);
4920 WALK_SUBEXPR (co
->expr4
);
4921 for (b
= co
->block
; b
; b
= b
->block
)
4923 WALK_SUBEXPR (b
->expr1
);
4924 WALK_SUBEXPR (b
->expr2
);
4925 WALK_SUBCODE (b
->next
);
4928 if (co
->op
== EXEC_FORALL
)
4931 if (co
->op
== EXEC_DO
)
4934 if (co
->op
== EXEC_IF
)
4937 if (co
->op
== EXEC_SELECT
)
4940 in_omp_workshare
= saved_in_omp_workshare
;
4941 in_where
= saved_in_where
;