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. */
1109 struct do_stack
*prev
;
1114 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1115 optimize by replacing do loops with their analog array slices. For
1118 write (*,*) (a(i), i=1,4)
1122 write (*,*) a(1:4:1) . */
1125 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1128 gfc_expr
*new_e
, *expr
, *start
;
1130 struct do_stack ds_push
;
1131 int i
, future_rank
= 0;
1132 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1135 /* Find the first transfer/do statement. */
1136 for (curr
= code
; curr
; curr
= curr
->next
)
1138 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1142 /* Ensure it is the only transfer/do statement because cases like
1144 write (*,*) (a(i), b(i), i=1,4)
1146 cannot be optimized. */
1148 if (!curr
|| curr
->next
)
1151 if (curr
->op
== EXEC_DO
)
1153 if (curr
->ext
.iterator
->var
->ref
)
1155 ds_push
.prev
= stack_top
;
1156 ds_push
.iter
= curr
->ext
.iterator
;
1157 ds_push
.code
= curr
;
1158 stack_top
= &ds_push
;
1159 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1161 if (curr
!= stack_top
->code
&& !*has_reached
)
1163 curr
->block
->next
= NULL
;
1164 gfc_free_statements (curr
);
1167 *has_reached
= true;
1173 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1177 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1180 /* Find the iterators belonging to each variable and check conditions. */
1181 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1183 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1184 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1187 start
= ref
->u
.ar
.start
[i
];
1188 gfc_simplify_expr (start
, 0);
1189 switch (start
->expr_type
)
1193 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1197 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1198 if (!stack_top
|| !stack_top
->iter
1199 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1201 /* Check for (a(i,i), i=1,3). */
1205 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1212 iters
[i
] = stack_top
->iter
;
1213 stack_top
= stack_top
->prev
;
1221 switch (start
->value
.op
.op
)
1223 case INTRINSIC_PLUS
:
1224 case INTRINSIC_TIMES
:
1225 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1226 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1228 case INTRINSIC_MINUS
:
1229 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1230 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1231 || start
->value
.op
.op1
->ref
)
1233 if (!stack_top
|| !stack_top
->iter
1234 || stack_top
->iter
->var
->symtree
1235 != start
->value
.op
.op1
->symtree
)
1237 iters
[i
] = stack_top
->iter
;
1238 stack_top
= stack_top
->prev
;
1250 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1251 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1255 gfc_expr
*var
= iters
[i
]->var
;
1256 for (int j
= i
- 1; j
< i
; j
++)
1259 && (gfc_check_dependency (var
, iters
[j
]->start
, true)
1260 || gfc_check_dependency (var
, iters
[j
]->end
, true)
1261 || gfc_check_dependency (var
, iters
[j
]->step
, true)))
1267 /* Create new expr. */
1268 new_e
= gfc_copy_expr (curr
->expr1
);
1269 new_e
->expr_type
= EXPR_VARIABLE
;
1270 new_e
->rank
= future_rank
;
1271 if (curr
->expr1
->shape
)
1272 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1274 /* Assign new starts, ends and strides if necessary. */
1275 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1279 start
= ref
->u
.ar
.start
[i
];
1280 switch (start
->expr_type
)
1283 gfc_internal_error ("bad expression");
1286 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1287 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1288 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1289 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1290 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1291 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1294 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1295 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1296 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1297 expr
= gfc_copy_expr (start
);
1298 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1299 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1300 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1301 expr
= gfc_copy_expr (start
);
1302 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1303 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1304 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1305 switch (start
->value
.op
.op
)
1307 case INTRINSIC_MINUS
:
1308 case INTRINSIC_PLUS
:
1309 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1311 case INTRINSIC_TIMES
:
1312 expr
= gfc_copy_expr (start
);
1313 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1314 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1315 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1318 gfc_internal_error ("bad op");
1322 gfc_internal_error ("bad expression");
1325 curr
->expr1
= new_e
;
1327 /* Insert modified statement. Check whether the statement needs to be
1328 inserted at the lowest level. */
1329 if (!stack_top
->iter
)
1333 curr
->next
= prev
->next
->next
;
1338 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1339 stack_top
->code
->block
->next
= curr
;
1343 stack_top
->code
->block
->next
= curr
;
1347 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1348 tries to optimize its block. */
1351 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1352 void *data ATTRIBUTE_UNUSED
)
1354 gfc_code
**curr
, *prev
= NULL
;
1355 struct do_stack write
, first
;
1359 || ((*code
)->block
->op
!= EXEC_WRITE
1360 && (*code
)->block
->op
!= EXEC_READ
))
1368 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1370 if ((*curr
)->op
== EXEC_DO
)
1372 first
.prev
= &write
;
1373 first
.iter
= (*curr
)->ext
.iterator
;
1376 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1384 /* Optimize a namespace, including all contained namespaces.
1385 flag_frontend_optimize and flag_fronend_loop_interchange are
1386 handled separately. */
1389 optimize_namespace (gfc_namespace
*ns
)
1391 gfc_namespace
*saved_ns
= gfc_current_ns
;
1393 gfc_current_ns
= ns
;
1396 in_assoc_list
= false;
1397 in_omp_workshare
= false;
1399 if (flag_frontend_optimize
)
1401 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1402 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1403 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1404 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1405 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1406 if (flag_inline_matmul_limit
!= 0)
1412 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1417 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1419 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1424 if (flag_frontend_loop_interchange
)
1425 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1428 /* BLOCKs are handled in the expression walker below. */
1429 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1431 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1432 optimize_namespace (ns
);
1434 gfc_current_ns
= saved_ns
;
1437 /* Handle dependencies for allocatable strings which potentially redefine
1438 themselves in an assignment. */
1441 realloc_strings (gfc_namespace
*ns
)
1444 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1446 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1448 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1449 realloc_strings (ns
);
1455 optimize_reduction (gfc_namespace
*ns
)
1458 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1459 callback_reduction
, NULL
);
1461 /* BLOCKs are handled in the expression walker below. */
1462 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1464 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1465 optimize_reduction (ns
);
1469 /* Replace code like
1472 a = matmul(b,c) ; a = a + d
1473 where the array function is not elemental and not allocatable
1474 and does not depend on the left-hand side.
1478 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1486 if (e
->expr_type
== EXPR_OP
)
1488 switch (e
->value
.op
.op
)
1490 /* Unary operators and exponentiation: Only look at a single
1493 case INTRINSIC_UPLUS
:
1494 case INTRINSIC_UMINUS
:
1495 case INTRINSIC_PARENTHESES
:
1496 case INTRINSIC_POWER
:
1497 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1501 case INTRINSIC_CONCAT
:
1502 /* Do not do string concatenations. */
1506 /* Binary operators. */
1507 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1510 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1516 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1517 && ! (e
->value
.function
.esym
1518 && (e
->value
.function
.esym
->attr
.elemental
1519 || e
->value
.function
.esym
->attr
.allocatable
1520 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1521 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1522 && ! (e
->value
.function
.isym
1523 && (e
->value
.function
.isym
->elemental
1524 || e
->ts
.type
!= c
->expr1
->ts
.type
1525 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1526 && ! gfc_inline_intrinsic_function_p (e
))
1532 /* Insert a new assignment statement after the current one. */
1533 n
= XCNEW (gfc_code
);
1534 n
->op
= EXEC_ASSIGN
;
1539 n
->expr1
= gfc_copy_expr (c
->expr1
);
1540 n
->expr2
= c
->expr2
;
1541 new_expr
= gfc_copy_expr (c
->expr1
);
1549 /* Nothing to optimize. */
1553 /* Remove unneeded TRIMs at the end of expressions. */
1556 remove_trim (gfc_expr
*rhs
)
1564 /* Check for a // b // trim(c). Looping is probably not
1565 necessary because the parser usually generates
1566 (// (// a b ) trim(c) ) , but better safe than sorry. */
1568 while (rhs
->expr_type
== EXPR_OP
1569 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1570 rhs
= rhs
->value
.op
.op2
;
1572 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1573 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1575 strip_function_call (rhs
);
1576 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1584 /* Optimizations for an assignment. */
1587 optimize_assignment (gfc_code
* c
)
1589 gfc_expr
*lhs
, *rhs
;
1594 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1596 /* Optimize a = trim(b) to a = b. */
1599 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1600 if (is_empty_string (rhs
))
1601 rhs
->value
.character
.length
= 0;
1604 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1605 optimize_binop_array_assignment (c
, &rhs
, false);
1609 /* Remove an unneeded function call, modifying the expression.
1610 This replaces the function call with the value of its
1611 first argument. The rest of the argument list is freed. */
1614 strip_function_call (gfc_expr
*e
)
1617 gfc_actual_arglist
*a
;
1619 a
= e
->value
.function
.actual
;
1621 /* We should have at least one argument. */
1622 gcc_assert (a
->expr
!= NULL
);
1626 /* Free the remaining arglist, if any. */
1628 gfc_free_actual_arglist (a
->next
);
1630 /* Graft the argument expression onto the original function. */
1636 /* Optimization of lexical comparison functions. */
1639 optimize_lexical_comparison (gfc_expr
*e
)
1641 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1644 switch (e
->value
.function
.isym
->id
)
1647 return optimize_comparison (e
, INTRINSIC_LE
);
1650 return optimize_comparison (e
, INTRINSIC_GE
);
1653 return optimize_comparison (e
, INTRINSIC_GT
);
1656 return optimize_comparison (e
, INTRINSIC_LT
);
1664 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1665 do CHARACTER because of possible pessimization involving character
1669 combine_array_constructor (gfc_expr
*e
)
1672 gfc_expr
*op1
, *op2
;
1675 gfc_constructor
*c
, *new_c
;
1676 gfc_constructor_base oldbase
, newbase
;
1681 /* Array constructors have rank one. */
1685 /* Don't try to combine association lists, this makes no sense
1686 and leads to an ICE. */
1690 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1691 if (forall_level
> 0)
1694 /* Inside an iterator, things can get hairy; we are likely to create
1695 an invalid temporary variable. */
1696 if (iterator_level
> 0)
1699 op1
= e
->value
.op
.op1
;
1700 op2
= e
->value
.op
.op2
;
1705 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1706 scalar_first
= false;
1707 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1709 scalar_first
= true;
1710 op1
= e
->value
.op
.op2
;
1711 op2
= e
->value
.op
.op1
;
1716 if (op2
->ts
.type
== BT_CHARACTER
)
1719 /* This might be an expanded constructor with very many constant values. If
1720 we perform the operation here, we might end up with a long compile time
1721 and actually longer execution time, so a length bound is in order here.
1722 If the constructor constains something which is not a constant, it did
1723 not come from an expansion, so leave it alone. */
1725 #define CONSTR_LEN_MAX 4
1727 oldbase
= op1
->value
.constructor
;
1731 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1733 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1741 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1744 #undef CONSTR_LEN_MAX
1747 e
->expr_type
= EXPR_ARRAY
;
1749 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1751 for (c
= gfc_constructor_first (oldbase
); c
;
1752 c
= gfc_constructor_next (c
))
1754 new_expr
= gfc_get_expr ();
1755 new_expr
->ts
= e
->ts
;
1756 new_expr
->expr_type
= EXPR_OP
;
1757 new_expr
->rank
= c
->expr
->rank
;
1758 new_expr
->where
= c
->expr
->where
;
1759 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1763 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1764 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1768 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1769 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1772 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1773 new_c
->iterator
= c
->iterator
;
1777 gfc_free_expr (op1
);
1778 gfc_free_expr (op2
);
1779 gfc_free_expr (scalar
);
1781 e
->value
.constructor
= newbase
;
1785 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1786 2**k into ishift(1,k) */
1789 optimize_power (gfc_expr
*e
)
1791 gfc_expr
*op1
, *op2
;
1792 gfc_expr
*iand
, *ishft
;
1794 if (e
->ts
.type
!= BT_INTEGER
)
1797 op1
= e
->value
.op
.op1
;
1799 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1802 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1804 gfc_free_expr (op1
);
1806 op2
= e
->value
.op
.op2
;
1811 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1812 "_internal_iand", e
->where
, 2, op2
,
1813 gfc_get_int_expr (e
->ts
.kind
,
1816 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1817 "_internal_ishft", e
->where
, 2, iand
,
1818 gfc_get_int_expr (e
->ts
.kind
,
1821 e
->value
.op
.op
= INTRINSIC_MINUS
;
1822 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1823 e
->value
.op
.op2
= ishft
;
1826 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1828 gfc_free_expr (op1
);
1830 op2
= e
->value
.op
.op2
;
1834 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1835 "_internal_ishft", e
->where
, 2,
1836 gfc_get_int_expr (e
->ts
.kind
,
1843 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1845 op2
= e
->value
.op
.op2
;
1849 gfc_free_expr (op1
);
1850 gfc_free_expr (op2
);
1852 e
->expr_type
= EXPR_CONSTANT
;
1853 e
->value
.op
.op1
= NULL
;
1854 e
->value
.op
.op2
= NULL
;
1855 mpz_init_set_si (e
->value
.integer
, 1);
1856 /* Typespec and location are still OK. */
1863 /* Recursive optimization of operators. */
1866 optimize_op (gfc_expr
*e
)
1870 gfc_intrinsic_op op
= e
->value
.op
.op
;
1874 /* Only use new-style comparisons. */
1877 case INTRINSIC_EQ_OS
:
1881 case INTRINSIC_GE_OS
:
1885 case INTRINSIC_LE_OS
:
1889 case INTRINSIC_NE_OS
:
1893 case INTRINSIC_GT_OS
:
1897 case INTRINSIC_LT_OS
:
1913 changed
= optimize_comparison (e
, op
);
1916 /* Look at array constructors. */
1917 case INTRINSIC_PLUS
:
1918 case INTRINSIC_MINUS
:
1919 case INTRINSIC_TIMES
:
1920 case INTRINSIC_DIVIDE
:
1921 return combine_array_constructor (e
) || changed
;
1923 case INTRINSIC_POWER
:
1924 return optimize_power (e
);
1934 /* Return true if a constant string contains only blanks. */
1937 is_empty_string (gfc_expr
*e
)
1941 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1944 for (i
=0; i
< e
->value
.character
.length
; i
++)
1946 if (e
->value
.character
.string
[i
] != ' ')
1954 /* Insert a call to the intrinsic len_trim. Use a different name for
1955 the symbol tree so we don't run into trouble when the user has
1956 renamed len_trim for some reason. */
1959 get_len_trim_call (gfc_expr
*str
, int kind
)
1962 gfc_actual_arglist
*actual_arglist
, *next
;
1964 fcn
= gfc_get_expr ();
1965 fcn
->expr_type
= EXPR_FUNCTION
;
1966 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1967 actual_arglist
= gfc_get_actual_arglist ();
1968 actual_arglist
->expr
= str
;
1969 next
= gfc_get_actual_arglist ();
1970 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1971 actual_arglist
->next
= next
;
1973 fcn
->value
.function
.actual
= actual_arglist
;
1974 fcn
->where
= str
->where
;
1975 fcn
->ts
.type
= BT_INTEGER
;
1976 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1978 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1979 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1980 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1981 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1982 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1983 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1984 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1985 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1990 /* Optimize expressions for equality. */
1993 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1995 gfc_expr
*op1
, *op2
;
1999 gfc_actual_arglist
*firstarg
, *secondarg
;
2001 if (e
->expr_type
== EXPR_OP
)
2005 op1
= e
->value
.op
.op1
;
2006 op2
= e
->value
.op
.op2
;
2008 else if (e
->expr_type
== EXPR_FUNCTION
)
2010 /* One of the lexical comparison functions. */
2011 firstarg
= e
->value
.function
.actual
;
2012 secondarg
= firstarg
->next
;
2013 op1
= firstarg
->expr
;
2014 op2
= secondarg
->expr
;
2019 /* Strip off unneeded TRIM calls from string comparisons. */
2021 change
= remove_trim (op1
);
2023 if (remove_trim (op2
))
2026 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2027 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2028 handles them well). However, there are also cases that need a non-scalar
2029 argument. For example the any intrinsic. See PR 45380. */
2033 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2035 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2036 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2038 bool empty_op1
, empty_op2
;
2039 empty_op1
= is_empty_string (op1
);
2040 empty_op2
= is_empty_string (op2
);
2042 if (empty_op1
|| empty_op2
)
2048 /* This can only happen when an error for comparing
2049 characters of different kinds has already been issued. */
2050 if (empty_op1
&& empty_op2
)
2053 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2054 str
= empty_op1
? op2
: op1
;
2056 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2060 gfc_free_expr (op1
);
2062 gfc_free_expr (op2
);
2066 e
->value
.op
.op1
= fcn
;
2067 e
->value
.op
.op2
= zero
;
2072 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2074 if (flag_finite_math_only
2075 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2076 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2078 eq
= gfc_dep_compare_expr (op1
, op2
);
2081 /* Replace A // B < A // C with B < C, and A // B < C // B
2083 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2084 && op1
->expr_type
== EXPR_OP
2085 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2086 && op2
->expr_type
== EXPR_OP
2087 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2089 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2090 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2091 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2092 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2094 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2096 /* Watch out for 'A ' // x vs. 'A' // x. */
2098 if (op1_left
->expr_type
== EXPR_CONSTANT
2099 && op2_left
->expr_type
== EXPR_CONSTANT
2100 && op1_left
->value
.character
.length
2101 != op2_left
->value
.character
.length
)
2109 firstarg
->expr
= op1_right
;
2110 secondarg
->expr
= op2_right
;
2114 e
->value
.op
.op1
= op1_right
;
2115 e
->value
.op
.op2
= op2_right
;
2117 optimize_comparison (e
, op
);
2121 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2127 firstarg
->expr
= op1_left
;
2128 secondarg
->expr
= op2_left
;
2132 e
->value
.op
.op1
= op1_left
;
2133 e
->value
.op
.op2
= op2_left
;
2136 optimize_comparison (e
, op
);
2143 /* eq can only be -1, 0 or 1 at this point. */
2171 gfc_internal_error ("illegal OP in optimize_comparison");
2175 /* Replace the expression by a constant expression. The typespec
2176 and where remains the way it is. */
2179 e
->expr_type
= EXPR_CONSTANT
;
2180 e
->value
.logical
= result
;
2188 /* Optimize a trim function by replacing it with an equivalent substring
2189 involving a call to len_trim. This only works for expressions where
2190 variables are trimmed. Return true if anything was modified. */
2193 optimize_trim (gfc_expr
*e
)
2198 gfc_ref
**rr
= NULL
;
2200 /* Don't do this optimization within an argument list, because
2201 otherwise aliasing issues may occur. */
2203 if (count_arglist
!= 1)
2206 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2207 || e
->value
.function
.isym
== NULL
2208 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2211 a
= e
->value
.function
.actual
->expr
;
2213 if (a
->expr_type
!= EXPR_VARIABLE
)
2216 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2218 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2221 /* Follow all references to find the correct place to put the newly
2222 created reference. FIXME: Also handle substring references and
2223 array references. Array references cause strange regressions at
2228 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2230 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2235 strip_function_call (e
);
2240 /* Create the reference. */
2242 ref
= gfc_get_ref ();
2243 ref
->type
= REF_SUBSTRING
;
2245 /* Set the start of the reference. */
2247 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2249 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2251 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2253 /* Set the end of the reference to the call to len_trim. */
2255 ref
->u
.ss
.end
= fcn
;
2256 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2261 /* Optimize minloc(b), where b is rank 1 array, into
2262 (/ minloc(b, dim=1) /), and similarly for maxloc,
2263 as the latter forms are expanded inline. */
2266 optimize_minmaxloc (gfc_expr
**e
)
2269 gfc_actual_arglist
*a
;
2273 || fn
->value
.function
.actual
== NULL
2274 || fn
->value
.function
.actual
->expr
== NULL
2275 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2278 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2279 (*e
)->shape
= fn
->shape
;
2282 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2284 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2285 strcpy (name
, fn
->value
.function
.name
);
2286 p
= strstr (name
, "loc0");
2288 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2289 if (fn
->value
.function
.actual
->next
)
2291 a
= fn
->value
.function
.actual
->next
;
2292 gcc_assert (a
->expr
== NULL
);
2296 a
= gfc_get_actual_arglist ();
2297 fn
->value
.function
.actual
->next
= a
;
2299 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2301 mpz_set_ui (a
->expr
->value
.integer
, 1);
2304 /* Callback function for code checking that we do not pass a DO variable to an
2305 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2308 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2309 void *data ATTRIBUTE_UNUSED
)
2313 gfc_formal_arglist
*f
;
2314 gfc_actual_arglist
*a
;
2321 /* If the doloop_list grew, we have to truncate it here. */
2323 if ((unsigned) doloop_level
< doloop_list
.length())
2324 doloop_list
.truncate (doloop_level
);
2331 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2336 loop
.branch_level
= if_level
+ select_level
;
2337 loop
.seen_goto
= false;
2338 doloop_list
.safe_push (loop
);
2341 /* If anything could transfer control away from a suspicious
2342 subscript, make sure to set seen_goto in the current DO loop
2347 case EXEC_ERROR_STOP
:
2353 if (co
->ext
.open
->err
)
2358 if (co
->ext
.close
->err
)
2362 case EXEC_BACKSPACE
:
2367 if (co
->ext
.filepos
->err
)
2372 if (co
->ext
.filepos
->err
)
2378 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2383 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2384 loop
.seen_goto
= true;
2389 if (co
->resolved_sym
== NULL
)
2392 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2394 /* Withot a formal arglist, there is only unknown INTENT,
2395 which we don't check for. */
2403 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2411 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2413 if (a
->expr
&& a
->expr
->symtree
2414 && a
->expr
->symtree
->n
.sym
== do_sym
)
2416 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2417 gfc_error_now ("Variable %qs at %L set to undefined "
2418 "value inside loop beginning at %L as "
2419 "INTENT(OUT) argument to subroutine %qs",
2420 do_sym
->name
, &a
->expr
->where
,
2421 &(doloop_list
[i
].c
->loc
),
2422 co
->symtree
->n
.sym
->name
);
2423 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2424 gfc_error_now ("Variable %qs at %L not definable inside "
2425 "loop beginning at %L as INTENT(INOUT) "
2426 "argument to subroutine %qs",
2427 do_sym
->name
, &a
->expr
->where
,
2428 &(doloop_list
[i
].c
->loc
),
2429 co
->symtree
->n
.sym
->name
);
2440 if (seen_goto
&& doloop_level
> 0)
2441 doloop_list
[doloop_level
-1].seen_goto
= true;
2446 /* Callback function to warn about different things within DO loops. */
2449 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2450 void *data ATTRIBUTE_UNUSED
)
2454 if (doloop_list
.length () == 0)
2457 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2460 last
= &doloop_list
.last();
2461 if (last
->seen_goto
&& !warn_do_subscript
)
2464 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2476 /* Callback function - if the expression is the variable in data->sym,
2477 replace it with a constant from data->val. */
2480 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2487 if (ex
->expr_type
!= EXPR_VARIABLE
)
2490 d
= (insert_index_t
*) data
;
2491 if (ex
->symtree
->n
.sym
!= d
->sym
)
2494 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2495 mpz_set (n
->value
.integer
, d
->val
);
2502 /* In the expression e, replace occurrences of the variable sym with
2503 val. If this results in a constant expression, return true and
2504 return the value in ret. Return false if the expression already
2505 is a constant. Caller has to clear ret in that case. */
2508 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2511 insert_index_t data
;
2514 if (e
->expr_type
== EXPR_CONSTANT
)
2517 n
= gfc_copy_expr (e
);
2519 mpz_init_set (data
.val
, val
);
2520 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2521 gfc_simplify_expr (n
, 0);
2523 if (n
->expr_type
== EXPR_CONSTANT
)
2526 mpz_init_set (ret
, n
->value
.integer
);
2531 mpz_clear (data
.val
);
2537 /* Check array subscripts for possible out-of-bounds accesses in DO
2538 loops with constant bounds. */
2541 do_subscript (gfc_expr
**e
)
2551 /* Constants are already checked. */
2552 if (v
->expr_type
== EXPR_CONSTANT
)
2555 /* Wrong warnings will be generated in an associate list. */
2559 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2561 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2564 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2567 mpz_t do_start
, do_step
, do_end
;
2568 bool have_do_start
, have_do_end
;
2569 bool error_not_proven
;
2576 /* If we are within a branch, or a goto or equivalent
2577 was seen in the DO loop before, then we cannot prove that
2578 this expression is actually evaluated. Don't do anything
2579 unless we want to see it all. */
2580 error_not_proven
= lp
->seen_goto
2581 || lp
->branch_level
< if_level
+ select_level
;
2583 if (error_not_proven
&& !warn_do_subscript
)
2586 if (error_not_proven
)
2587 warn
= OPT_Wdo_subscript
;
2591 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2592 if (do_sym
->ts
.type
!= BT_INTEGER
)
2595 /* If we do not know about the stepsize, the loop may be zero trip.
2596 Do not warn in this case. */
2598 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2599 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2603 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2605 have_do_start
= true;
2606 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2609 have_do_start
= false;
2612 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2615 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2618 have_do_end
= false;
2620 if (!have_do_start
&& !have_do_end
)
2623 /* May have to correct the end value if the step does not equal
2625 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2631 mpz_sub (diff
, do_end
, do_start
);
2632 mpz_tdiv_r (rem
, diff
, do_step
);
2633 mpz_sub (do_end
, do_end
, rem
);
2638 for (i
= 0; i
< ar
->dimen
; i
++)
2641 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2642 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2644 if (ar
->as
->lower
[i
]
2645 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2646 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2647 gfc_warning (warn
, "Array reference at %L out of bounds "
2648 "(%ld < %ld) in loop beginning at %L",
2649 &ar
->start
[i
]->where
, mpz_get_si (val
),
2650 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2651 &doloop_list
[j
].c
->loc
);
2653 if (ar
->as
->upper
[i
]
2654 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2655 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2656 gfc_warning (warn
, "Array reference at %L out of bounds "
2657 "(%ld > %ld) in loop beginning at %L",
2658 &ar
->start
[i
]->where
, mpz_get_si (val
),
2659 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2660 &doloop_list
[j
].c
->loc
);
2665 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2666 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2668 if (ar
->as
->lower
[i
]
2669 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2670 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2671 gfc_warning (warn
, "Array reference at %L out of bounds "
2672 "(%ld < %ld) in loop beginning at %L",
2673 &ar
->start
[i
]->where
, mpz_get_si (val
),
2674 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2675 &doloop_list
[j
].c
->loc
);
2677 if (ar
->as
->upper
[i
]
2678 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2679 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2680 gfc_warning (warn
, "Array reference at %L out of bounds "
2681 "(%ld > %ld) in loop beginning at %L",
2682 &ar
->start
[i
]->where
, mpz_get_si (val
),
2683 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2684 &doloop_list
[j
].c
->loc
);
2694 /* Function for functions checking that we do not pass a DO variable
2695 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2698 do_intent (gfc_expr
**e
)
2700 gfc_formal_arglist
*f
;
2701 gfc_actual_arglist
*a
;
2708 if (expr
->expr_type
!= EXPR_FUNCTION
)
2711 /* Intrinsic functions don't modify their arguments. */
2713 if (expr
->value
.function
.isym
)
2716 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2718 /* Without a formal arglist, there is only unknown INTENT,
2719 which we don't check for. */
2723 a
= expr
->value
.function
.actual
;
2727 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2734 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2736 if (a
->expr
&& a
->expr
->symtree
2737 && a
->expr
->symtree
->n
.sym
== do_sym
)
2739 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2740 gfc_error_now ("Variable %qs at %L set to undefined value "
2741 "inside loop beginning at %L as INTENT(OUT) "
2742 "argument to function %qs", do_sym
->name
,
2743 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2744 expr
->symtree
->n
.sym
->name
);
2745 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2746 gfc_error_now ("Variable %qs at %L not definable inside loop"
2747 " beginning at %L as INTENT(INOUT) argument to"
2748 " function %qs", do_sym
->name
,
2749 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2750 expr
->symtree
->n
.sym
->name
);
2761 doloop_warn (gfc_namespace
*ns
)
2763 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2766 /* This selction deals with inlining calls to MATMUL. */
2768 /* Replace calls to matmul outside of straight assignments with a temporary
2769 variable so that later inlining will work. */
2772 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2776 bool *found
= (bool *) data
;
2780 if (e
->expr_type
!= EXPR_FUNCTION
2781 || e
->value
.function
.isym
== NULL
2782 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2785 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2786 || in_where
|| in_assoc_list
)
2789 /* Check if this is already in the form c = matmul(a,b). */
2791 if ((*current_code
)->expr2
== e
)
2794 n
= create_var (e
, "matmul");
2796 /* If create_var is unable to create a variable (for example if
2797 -fno-realloc-lhs is in force with a variable that does not have bounds
2798 known at compile-time), just return. */
2808 /* Set current_code and associated variables so that matmul_to_var_expr can
2812 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2813 void *data ATTRIBUTE_UNUSED
)
2815 if (current_code
!= c
)
2818 inserted_block
= NULL
;
2819 changed_statement
= NULL
;
2826 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2827 for a and b if there is a dependency between the arguments and the
2828 result variable or if a or b are the result of calculations that cannot
2829 be handled by the inliner. */
2832 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2833 void *data ATTRIBUTE_UNUSED
)
2835 gfc_expr
*expr1
, *expr2
;
2837 gfc_actual_arglist
*a
, *b
;
2839 gfc_expr
*matrix_a
, *matrix_b
;
2840 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2844 if (co
->op
!= EXEC_ASSIGN
)
2847 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2851 /* This has some duplication with inline_matmul_assign. This
2852 is because the creation of temporary variables could still fail,
2853 and inline_matmul_assign still needs to be able to handle these
2858 if (expr2
->expr_type
!= EXPR_FUNCTION
2859 || expr2
->value
.function
.isym
== NULL
2860 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2864 a
= expr2
->value
.function
.actual
;
2865 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2866 if (matrix_a
!= NULL
)
2868 if (matrix_a
->expr_type
== EXPR_VARIABLE
2869 && (gfc_check_dependency (matrix_a
, expr1
, true)
2870 || has_dimen_vector_ref (matrix_a
)))
2878 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2879 if (matrix_b
!= NULL
)
2881 if (matrix_b
->expr_type
== EXPR_VARIABLE
2882 && (gfc_check_dependency (matrix_b
, expr1
, true)
2883 || has_dimen_vector_ref (matrix_b
)))
2889 if (!a_tmp
&& !b_tmp
)
2893 inserted_block
= NULL
;
2894 changed_statement
= NULL
;
2898 at
= create_var (a
->expr
,"mma");
2905 bt
= create_var (b
->expr
,"mmb");
2912 /* Auxiliary function to build and simplify an array inquiry function.
2913 dim is zero-based. */
2916 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2919 gfc_expr
*dim_arg
, *kind
;
2925 case GFC_ISYM_LBOUND
:
2926 name
= "_gfortran_lbound";
2929 case GFC_ISYM_UBOUND
:
2930 name
= "_gfortran_ubound";
2934 name
= "_gfortran_size";
2941 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2942 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2943 gfc_index_integer_kind
);
2945 ec
= gfc_copy_expr (e
);
2947 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2949 ec
->no_bounds_check
= 1;
2950 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2952 gfc_simplify_expr (fcn
, 0);
2953 fcn
->no_bounds_check
= 1;
2957 /* Builds a logical expression. */
2960 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2965 ts
.type
= BT_LOGICAL
;
2966 ts
.kind
= gfc_default_logical_kind
;
2967 res
= gfc_get_expr ();
2968 res
->where
= e1
->where
;
2969 res
->expr_type
= EXPR_OP
;
2970 res
->value
.op
.op
= op
;
2971 res
->value
.op
.op1
= e1
;
2972 res
->value
.op
.op2
= e2
;
2979 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2980 compatible typespecs. */
2983 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2987 res
= gfc_get_expr ();
2989 res
->where
= e1
->where
;
2990 res
->expr_type
= EXPR_OP
;
2991 res
->value
.op
.op
= op
;
2992 res
->value
.op
.op1
= e1
;
2993 res
->value
.op
.op2
= e2
;
2994 gfc_simplify_expr (res
, 0);
2998 /* Generate the IF statement for a runtime check if we want to do inlining or
2999 not - putting in the code for both branches and putting it into the syntax
3000 tree is the caller's responsibility. For fixed array sizes, this should be
3001 removed by DCE. Only called for rank-two matrices A and B. */
3004 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
3006 gfc_expr
*inline_limit
;
3007 gfc_code
*if_1
, *if_2
, *else_2
;
3008 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3012 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
3014 /* Calculation is done in real to avoid integer overflow. */
3016 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3018 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
3020 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3023 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3024 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3025 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3029 ts
.kind
= gfc_default_real_kind
;
3030 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3031 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3032 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3034 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3035 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3037 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3038 gfc_simplify_expr (cond
, 0);
3040 else_2
= XCNEW (gfc_code
);
3041 else_2
->op
= EXEC_IF
;
3042 else_2
->loc
= a
->where
;
3044 if_2
= XCNEW (gfc_code
);
3047 if_2
->loc
= a
->where
;
3048 if_2
->block
= else_2
;
3050 if_1
= XCNEW (gfc_code
);
3053 if_1
->loc
= a
->where
;
3059 /* Insert code to issue a runtime error if the expressions are not equal. */
3062 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3065 gfc_code
*if_1
, *if_2
;
3067 gfc_actual_arglist
*a1
, *a2
, *a3
;
3069 gcc_assert (e1
->where
.lb
);
3070 /* Build the call to runtime_error. */
3071 c
= XCNEW (gfc_code
);
3075 /* Get a null-terminated message string. */
3077 a1
= gfc_get_actual_arglist ();
3078 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3079 msg
, strlen(msg
)+1);
3082 /* Pass the value of the first expression. */
3083 a2
= gfc_get_actual_arglist ();
3084 a2
->expr
= gfc_copy_expr (e1
);
3087 /* Pass the value of the second expression. */
3088 a3
= gfc_get_actual_arglist ();
3089 a3
->expr
= gfc_copy_expr (e2
);
3092 gfc_check_fe_runtime_error (c
->ext
.actual
);
3093 gfc_resolve_fe_runtime_error (c
);
3095 if_2
= XCNEW (gfc_code
);
3097 if_2
->loc
= e1
->where
;
3100 if_1
= XCNEW (gfc_code
);
3103 if_1
->loc
= e1
->where
;
3105 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3106 gfc_simplify_expr (cond
, 0);
3112 /* Handle matrix reallocation. Caller is responsible to insert into
3115 For the two-dimensional case, build
3117 if (allocated(c)) then
3118 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3120 allocate (c(size(a,1), size(b,2)))
3123 allocate (c(size(a,1),size(b,2)))
3126 and for the other cases correspondingly.
3130 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3131 enum matrix_case m_case
)
3134 gfc_expr
*allocated
, *alloc_expr
;
3135 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3136 gfc_code
*else_alloc
;
3137 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3139 gfc_expr
*cond
, *ne1
, *ne2
;
3141 if (warn_realloc_lhs
)
3142 gfc_warning (OPT_Wrealloc_lhs
,
3143 "Code for reallocating the allocatable array at %L will "
3144 "be added", &c
->where
);
3146 alloc_expr
= gfc_copy_expr (c
);
3148 ar
= gfc_find_array_ref (alloc_expr
);
3149 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3151 /* c comes in as a full ref. Change it into a copy and make it into an
3152 element ref so it has the right form for for ALLOCATE. In the same
3153 switch statement, also generate the size comparison for the secod IF
3156 ar
->type
= AR_ELEMENT
;
3161 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3162 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3163 ne1
= build_logical_expr (INTRINSIC_NE
,
3164 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3165 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3166 ne2
= build_logical_expr (INTRINSIC_NE
,
3167 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3168 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3169 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3173 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3174 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3176 ne1
= build_logical_expr (INTRINSIC_NE
,
3177 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3178 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3179 ne2
= build_logical_expr (INTRINSIC_NE
,
3180 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3181 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3182 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3187 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3188 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3190 ne1
= build_logical_expr (INTRINSIC_NE
,
3191 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3192 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3193 ne2
= build_logical_expr (INTRINSIC_NE
,
3194 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3195 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3196 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3200 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3201 cond
= build_logical_expr (INTRINSIC_NE
,
3202 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3203 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3207 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3208 cond
= build_logical_expr (INTRINSIC_NE
,
3209 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3210 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3218 gfc_simplify_expr (cond
, 0);
3220 /* We need two identical allocate statements in two
3221 branches of the IF statement. */
3223 allocate1
= XCNEW (gfc_code
);
3224 allocate1
->op
= EXEC_ALLOCATE
;
3225 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3226 allocate1
->loc
= c
->where
;
3227 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3229 allocate_else
= XCNEW (gfc_code
);
3230 allocate_else
->op
= EXEC_ALLOCATE
;
3231 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3232 allocate_else
->loc
= c
->where
;
3233 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3235 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3236 "_gfortran_allocated", c
->where
,
3237 1, gfc_copy_expr (c
));
3239 deallocate
= XCNEW (gfc_code
);
3240 deallocate
->op
= EXEC_DEALLOCATE
;
3241 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3242 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3243 deallocate
->next
= allocate1
;
3244 deallocate
->loc
= c
->where
;
3246 if_size_2
= XCNEW (gfc_code
);
3247 if_size_2
->op
= EXEC_IF
;
3248 if_size_2
->expr1
= cond
;
3249 if_size_2
->loc
= c
->where
;
3250 if_size_2
->next
= deallocate
;
3252 if_size_1
= XCNEW (gfc_code
);
3253 if_size_1
->op
= EXEC_IF
;
3254 if_size_1
->block
= if_size_2
;
3255 if_size_1
->loc
= c
->where
;
3257 else_alloc
= XCNEW (gfc_code
);
3258 else_alloc
->op
= EXEC_IF
;
3259 else_alloc
->loc
= c
->where
;
3260 else_alloc
->next
= allocate_else
;
3262 if_alloc_2
= XCNEW (gfc_code
);
3263 if_alloc_2
->op
= EXEC_IF
;
3264 if_alloc_2
->expr1
= allocated
;
3265 if_alloc_2
->loc
= c
->where
;
3266 if_alloc_2
->next
= if_size_1
;
3267 if_alloc_2
->block
= else_alloc
;
3269 if_alloc_1
= XCNEW (gfc_code
);
3270 if_alloc_1
->op
= EXEC_IF
;
3271 if_alloc_1
->block
= if_alloc_2
;
3272 if_alloc_1
->loc
= c
->where
;
3277 /* Callback function for has_function_or_op. */
3280 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3281 void *data ATTRIBUTE_UNUSED
)
3286 return (*e
)->expr_type
== EXPR_FUNCTION
3287 || (*e
)->expr_type
== EXPR_OP
;
3290 /* Returns true if the expression contains a function. */
3293 has_function_or_op (gfc_expr
**e
)
3298 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3301 /* Freeze (assign to a temporary variable) a single expression. */
3304 freeze_expr (gfc_expr
**ep
)
3307 if (has_function_or_op (ep
))
3309 ne
= create_var (*ep
, "freeze");
3314 /* Go through an expression's references and assign them to temporary
3315 variables if they contain functions. This is usually done prior to
3316 front-end scalarization to avoid multiple invocations of functions. */
3319 freeze_references (gfc_expr
*e
)
3325 for (r
=e
->ref
; r
; r
=r
->next
)
3327 if (r
->type
== REF_SUBSTRING
)
3329 if (r
->u
.ss
.start
!= NULL
)
3330 freeze_expr (&r
->u
.ss
.start
);
3332 if (r
->u
.ss
.end
!= NULL
)
3333 freeze_expr (&r
->u
.ss
.end
);
3335 else if (r
->type
== REF_ARRAY
)
3344 for (i
=0; i
<ar
->dimen
; i
++)
3346 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3348 freeze_expr (&ar
->start
[i
]);
3349 freeze_expr (&ar
->end
[i
]);
3350 freeze_expr (&ar
->stride
[i
]);
3352 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3354 freeze_expr (&ar
->start
[i
]);
3360 for (i
=0; i
<ar
->dimen
; i
++)
3361 freeze_expr (&ar
->start
[i
]);
3371 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3374 convert_to_index_kind (gfc_expr
*e
)
3378 gcc_assert (e
!= NULL
);
3380 res
= gfc_copy_expr (e
);
3382 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3384 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3388 ts
.type
= BT_INTEGER
;
3389 ts
.kind
= gfc_index_integer_kind
;
3391 gfc_convert_type_warn (e
, &ts
, 2, 0);
3397 /* Function to create a DO loop including creation of the
3398 iteration variable. gfc_expr are copied.*/
3401 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3402 gfc_namespace
*ns
, char *vname
)
3405 char name
[GFC_MAX_SYMBOL_LEN
+1];
3406 gfc_symtree
*symtree
;
3411 /* Create an expression for the iteration variable. */
3413 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3415 sprintf (name
, "__var_%d_do", var_num
++);
3418 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3421 /* Create the loop variable. */
3423 symbol
= symtree
->n
.sym
;
3424 symbol
->ts
.type
= BT_INTEGER
;
3425 symbol
->ts
.kind
= gfc_index_integer_kind
;
3426 symbol
->attr
.flavor
= FL_VARIABLE
;
3427 symbol
->attr
.referenced
= 1;
3428 symbol
->attr
.dimension
= 0;
3429 symbol
->attr
.fe_temp
= 1;
3430 gfc_commit_symbol (symbol
);
3432 i
= gfc_get_expr ();
3433 i
->expr_type
= EXPR_VARIABLE
;
3437 i
->symtree
= symtree
;
3439 /* ... and the nested DO statements. */
3440 n
= XCNEW (gfc_code
);
3443 n
->ext
.iterator
= gfc_get_iterator ();
3444 n
->ext
.iterator
->var
= i
;
3445 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3446 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3448 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3450 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3453 n2
= XCNEW (gfc_code
);
3461 /* Get the upper bound of the DO loops for matmul along a dimension. This
3465 get_size_m1 (gfc_expr
*e
, int dimen
)
3470 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3472 res
= gfc_get_constant_expr (BT_INTEGER
,
3473 gfc_index_integer_kind
, &e
->where
);
3474 mpz_sub_ui (res
->value
.integer
, size
, 1);
3479 res
= get_operand (INTRINSIC_MINUS
,
3480 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3481 gfc_get_int_expr (gfc_index_integer_kind
,
3483 gfc_simplify_expr (res
, 0);
3489 /* Function to return a scalarized expression. It is assumed that indices are
3490 zero based to make generation of DO loops easier. A zero as index will
3491 access the first element along a dimension. Single element references will
3492 be skipped. A NULL as an expression will be replaced by a full reference.
3493 This assumes that the index loops have gfc_index_integer_kind, and that all
3494 references have been frozen. */
3497 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3506 e
= gfc_copy_expr(e_in
);
3510 ar
= gfc_find_array_ref (e
);
3512 /* We scalarize count_index variables, reducing the rank by count_index. */
3514 e
->rank
= rank
- count_index
;
3516 was_fullref
= ar
->type
== AR_FULL
;
3519 ar
->type
= AR_ELEMENT
;
3521 ar
->type
= AR_SECTION
;
3523 /* Loop over the indices. For each index, create the expression
3524 index * stride + lbound(e, dim). */
3527 for (i
=0; i
< ar
->dimen
; i
++)
3529 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3531 if (index
[i_index
] != NULL
)
3533 gfc_expr
*lbound
, *nindex
;
3536 loopvar
= gfc_copy_expr (index
[i_index
]);
3542 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3543 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3547 ts
.type
= BT_INTEGER
;
3548 ts
.kind
= gfc_index_integer_kind
;
3549 gfc_convert_type (tmp
, &ts
, 2);
3551 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3556 /* Calculate the lower bound of the expression. */
3559 lbound
= gfc_copy_expr (ar
->start
[i
]);
3560 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3564 ts
.type
= BT_INTEGER
;
3565 ts
.kind
= gfc_index_integer_kind
;
3566 gfc_convert_type (lbound
, &ts
, 2);
3575 lbound_e
= gfc_copy_expr (e_in
);
3577 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3578 if (ref
->type
== REF_ARRAY
3579 && (ref
->u
.ar
.type
== AR_FULL
3580 || ref
->u
.ar
.type
== AR_SECTION
))
3585 gfc_free_ref_list (ref
->next
);
3591 /* Look at full individual sections, like a(:). The first index
3592 is the lbound of a full ref. */
3599 /* For assumed size, we need to keep around the final
3600 reference in order not to get an error on resolution
3601 below, and we cannot use AR_FULL. */
3603 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3605 ar
->type
= AR_SECTION
;
3614 for (j
= 0; j
< to
; j
++)
3616 gfc_free_expr (ar
->start
[j
]);
3617 ar
->start
[j
] = NULL
;
3618 gfc_free_expr (ar
->end
[j
]);
3620 gfc_free_expr (ar
->stride
[j
]);
3621 ar
->stride
[j
] = NULL
;
3624 /* We have to get rid of the shape, if there is one. Do
3625 so by freeing it and calling gfc_resolve to rebuild
3626 it, if necessary. */
3628 if (lbound_e
->shape
)
3629 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3631 lbound_e
->rank
= ar
->dimen
;
3632 gfc_resolve_expr (lbound_e
);
3634 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3636 gfc_free_expr (lbound_e
);
3639 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3641 gfc_free_expr (ar
->start
[i
]);
3642 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3644 gfc_free_expr (ar
->end
[i
]);
3646 gfc_free_expr (ar
->stride
[i
]);
3647 ar
->stride
[i
] = NULL
;
3648 gfc_simplify_expr (ar
->start
[i
], 0);
3650 else if (was_fullref
)
3652 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3658 /* Bounds checking will be done before the loops if -fcheck=bounds
3660 e
->no_bounds_check
= 1;
3664 /* Helper function to check for a dimen vector as subscript. */
3667 has_dimen_vector_ref (gfc_expr
*e
)
3672 ar
= gfc_find_array_ref (e
);
3674 if (ar
->type
== AR_FULL
)
3677 for (i
=0; i
<ar
->dimen
; i
++)
3678 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3684 /* If handed an expression of the form
3688 check if A can be handled by matmul and return if there is an uneven number
3689 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3690 otherwise. The caller has to check for the correct rank. */
3693 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3700 if (e
->expr_type
== EXPR_VARIABLE
)
3702 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3705 else if (e
->expr_type
== EXPR_FUNCTION
)
3707 if (e
->value
.function
.isym
== NULL
)
3710 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3712 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3713 *transpose
= !*transpose
;
3719 e
= e
->value
.function
.actual
->expr
;
3726 /* Inline assignments of the form c = matmul(a,b).
3727 Handle only the cases currently where b and c are rank-two arrays.
3729 This basically translates the code to
3735 do k=0, size(a, 2)-1
3736 do i=0, size(a, 1)-1
3737 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3738 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3739 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3740 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3749 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3750 void *data ATTRIBUTE_UNUSED
)
3753 gfc_expr
*expr1
, *expr2
;
3754 gfc_expr
*matrix_a
, *matrix_b
;
3755 gfc_actual_arglist
*a
, *b
;
3756 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3758 gfc_expr
*u1
, *u2
, *u3
;
3760 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3762 gfc_expr
*var_1
, *var_2
, *var_3
;
3765 gfc_intrinsic_op op_times
, op_plus
;
3766 enum matrix_case m_case
;
3768 gfc_code
*if_limit
= NULL
;
3769 gfc_code
**next_code_point
;
3770 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3772 if (co
->op
!= EXEC_ASSIGN
)
3775 if (in_where
|| in_assoc_list
)
3778 /* The BLOCKS generated for the temporary variables and FORALL don't
3780 if (forall_level
> 0)
3783 /* For now don't do anything in OpenMP workshare, it confuses
3784 its translation, which expects only the allowed statements in there.
3785 We should figure out how to parallelize this eventually. */
3786 if (in_omp_workshare
)
3791 if (expr2
->expr_type
!= EXPR_FUNCTION
3792 || expr2
->value
.function
.isym
== NULL
3793 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3797 inserted_block
= NULL
;
3798 changed_statement
= NULL
;
3800 a
= expr2
->value
.function
.actual
;
3801 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3802 if (matrix_a
== NULL
)
3806 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3807 if (matrix_b
== NULL
)
3810 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3811 || has_dimen_vector_ref (matrix_b
))
3814 /* We do not handle data dependencies yet. */
3815 if (gfc_check_dependency (expr1
, matrix_a
, true)
3816 || gfc_check_dependency (expr1
, matrix_b
, true))
3820 if (matrix_a
->rank
== 2)
3824 if (matrix_b
->rank
== 2 && !transpose_b
)
3829 if (matrix_b
->rank
== 1)
3831 else /* matrix_b->rank == 2 */
3840 else /* matrix_a->rank == 1 */
3842 if (matrix_b
->rank
== 2)
3852 ns
= insert_block ();
3854 /* Assign the type of the zero expression for initializing the resulting
3855 array, and the expression (+ and * for real, integer and complex;
3856 .and. and .or for logical. */
3858 switch(expr1
->ts
.type
)
3861 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3862 op_times
= INTRINSIC_TIMES
;
3863 op_plus
= INTRINSIC_PLUS
;
3867 op_times
= INTRINSIC_AND
;
3868 op_plus
= INTRINSIC_OR
;
3869 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3873 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3875 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3876 op_times
= INTRINSIC_TIMES
;
3877 op_plus
= INTRINSIC_PLUS
;
3881 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3883 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3884 op_times
= INTRINSIC_TIMES
;
3885 op_plus
= INTRINSIC_PLUS
;
3893 current_code
= &ns
->code
;
3895 /* Freeze the references, keeping track of how many temporary variables were
3898 freeze_references (matrix_a
);
3899 freeze_references (matrix_b
);
3900 freeze_references (expr1
);
3903 next_code_point
= current_code
;
3906 next_code_point
= &ns
->code
;
3907 for (i
=0; i
<n_vars
; i
++)
3908 next_code_point
= &(*next_code_point
)->next
;
3911 /* Take care of the inline flag. If the limit check evaluates to a
3912 constant, dead code elimination will eliminate the unneeded branch. */
3914 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3916 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3918 /* Insert the original statement into the else branch. */
3919 if_limit
->block
->block
->next
= co
;
3922 /* ... and the new ones go into the original one. */
3923 *next_code_point
= if_limit
;
3924 next_code_point
= &if_limit
->block
->next
;
3927 zero_e
->no_bounds_check
= 1;
3929 assign_zero
= XCNEW (gfc_code
);
3930 assign_zero
->op
= EXEC_ASSIGN
;
3931 assign_zero
->loc
= co
->loc
;
3932 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3933 assign_zero
->expr1
->no_bounds_check
= 1;
3934 assign_zero
->expr2
= zero_e
;
3936 /* Handle the reallocation, if needed. */
3937 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3939 gfc_code
*lhs_alloc
;
3941 /* Only need to check a single dimension for the A2B2 case for
3942 bounds checking, the rest will be allocated. Also check this
3945 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3948 if (m_case
== A2B2
|| m_case
== A2B1
)
3952 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3953 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3954 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3955 "in MATMUL intrinsic: Is %ld, should be %ld");
3956 *next_code_point
= test
;
3957 next_code_point
= &test
->next
;
3959 else if (m_case
== A1B2
)
3963 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3964 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3965 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3966 "in MATMUL intrinsic: Is %ld, should be %ld");
3967 *next_code_point
= test
;
3968 next_code_point
= &test
->next
;
3972 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3974 *next_code_point
= lhs_alloc
;
3975 next_code_point
= &lhs_alloc
->next
;
3978 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3981 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3983 if (m_case
== A2B2
|| m_case
== A2B1
)
3985 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3986 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3987 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3988 "in MATMUL intrinsic: Is %ld, should be %ld");
3989 *next_code_point
= test
;
3990 next_code_point
= &test
->next
;
3992 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3993 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3996 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3997 "MATMUL intrinsic for dimension 1: "
3998 "is %ld, should be %ld");
3999 else if (m_case
== A2B1
)
4000 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
4001 "MATMUL intrinsic: "
4002 "is %ld, should be %ld");
4005 *next_code_point
= test
;
4006 next_code_point
= &test
->next
;
4008 else if (m_case
== A1B2
)
4010 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4011 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4012 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
4013 "in MATMUL intrinsic: Is %ld, should be %ld");
4014 *next_code_point
= test
;
4015 next_code_point
= &test
->next
;
4017 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4018 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4020 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
4021 "MATMUL intrinsic: "
4022 "is %ld, should be %ld");
4024 *next_code_point
= test
;
4025 next_code_point
= &test
->next
;
4030 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4031 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4032 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4033 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
4035 *next_code_point
= test
;
4036 next_code_point
= &test
->next
;
4039 if (m_case
== A2B2T
)
4041 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4042 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4043 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
4044 "MATMUL intrinsic for dimension 1: "
4045 "is %ld, should be %ld");
4047 *next_code_point
= test
;
4048 next_code_point
= &test
->next
;
4050 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4051 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4052 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
4053 "MATMUL intrinsic for dimension 2: "
4054 "is %ld, should be %ld");
4055 *next_code_point
= test
;
4056 next_code_point
= &test
->next
;
4058 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4059 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4061 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
4062 "MATMUL intrnisic for dimension 2: "
4063 "is %ld, should be %ld");
4064 *next_code_point
= test
;
4065 next_code_point
= &test
->next
;
4069 if (m_case
== A2TB2
)
4071 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4072 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4074 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
4075 "MATMUL intrinsic for dimension 1: "
4076 "is %ld, should be %ld");
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
, "Incorrect extent in return array in "
4084 "MATMUL intrinsic for dimension 2: "
4085 "is %ld, should be %ld");
4086 *next_code_point
= test
;
4087 next_code_point
= &test
->next
;
4089 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4090 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4092 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
4093 "MATMUL intrnisic for dimension 2: "
4094 "is %ld, should be %ld");
4095 *next_code_point
= test
;
4096 next_code_point
= &test
->next
;
4101 *next_code_point
= assign_zero
;
4103 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4105 assign_matmul
= XCNEW (gfc_code
);
4106 assign_matmul
->op
= EXEC_ASSIGN
;
4107 assign_matmul
->loc
= co
->loc
;
4109 /* Get the bounds for the loops, create them and create the scalarized
4115 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4117 u1
= get_size_m1 (matrix_b
, 2);
4118 u2
= get_size_m1 (matrix_a
, 2);
4119 u3
= get_size_m1 (matrix_a
, 1);
4121 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4122 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4123 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4125 do_1
->block
->next
= do_2
;
4126 do_2
->block
->next
= do_3
;
4127 do_3
->block
->next
= assign_matmul
;
4129 var_1
= do_1
->ext
.iterator
->var
;
4130 var_2
= do_2
->ext
.iterator
->var
;
4131 var_3
= do_3
->ext
.iterator
->var
;
4135 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4139 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4143 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4148 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4150 u1
= get_size_m1 (matrix_b
, 1);
4151 u2
= get_size_m1 (matrix_a
, 2);
4152 u3
= get_size_m1 (matrix_a
, 1);
4154 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4155 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4156 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4158 do_1
->block
->next
= do_2
;
4159 do_2
->block
->next
= do_3
;
4160 do_3
->block
->next
= assign_matmul
;
4162 var_1
= do_1
->ext
.iterator
->var
;
4163 var_2
= do_2
->ext
.iterator
->var
;
4164 var_3
= do_3
->ext
.iterator
->var
;
4168 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4172 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4176 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4181 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4183 u1
= get_size_m1 (matrix_a
, 2);
4184 u2
= get_size_m1 (matrix_b
, 2);
4185 u3
= get_size_m1 (matrix_a
, 1);
4187 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4188 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4189 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4191 do_1
->block
->next
= do_2
;
4192 do_2
->block
->next
= do_3
;
4193 do_3
->block
->next
= assign_matmul
;
4195 var_1
= do_1
->ext
.iterator
->var
;
4196 var_2
= do_2
->ext
.iterator
->var
;
4197 var_3
= do_3
->ext
.iterator
->var
;
4201 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4205 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4209 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4214 u1
= get_size_m1 (matrix_b
, 1);
4215 u2
= get_size_m1 (matrix_a
, 1);
4217 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4218 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4220 do_1
->block
->next
= do_2
;
4221 do_2
->block
->next
= assign_matmul
;
4223 var_1
= do_1
->ext
.iterator
->var
;
4224 var_2
= do_2
->ext
.iterator
->var
;
4227 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4231 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4234 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4239 u1
= get_size_m1 (matrix_b
, 2);
4240 u2
= get_size_m1 (matrix_a
, 1);
4242 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4243 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4245 do_1
->block
->next
= do_2
;
4246 do_2
->block
->next
= assign_matmul
;
4248 var_1
= do_1
->ext
.iterator
->var
;
4249 var_2
= do_2
->ext
.iterator
->var
;
4252 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4255 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4259 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4267 /* Build the conjg call around the variables. Set the typespec manually
4268 because gfc_build_intrinsic_call sometimes gets this wrong. */
4273 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4274 matrix_a
->where
, 1, ascalar
);
4282 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4283 matrix_b
->where
, 1, bscalar
);
4286 /* First loop comes after the zero assignment. */
4287 assign_zero
->next
= do_1
;
4289 /* Build the assignment expression in the loop. */
4290 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4292 mult
= get_operand (op_times
, ascalar
, bscalar
);
4293 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4295 /* If we don't want to keep the original statement around in
4296 the else branch, we can free it. */
4298 if (if_limit
== NULL
)
4299 gfc_free_statements(co
);
4303 gfc_free_expr (zero
);
4309 /* Code for index interchange for loops which are grouped together in DO
4310 CONCURRENT or FORALL statements. This is currently only applied if the
4311 iterations are grouped together in a single statement.
4313 For this transformation, it is assumed that memory access in strides is
4314 expensive, and that loops which access later indices (which access memory
4315 in bigger strides) should be moved to the first loops.
4317 For this, a loop over all the statements is executed, counting the times
4318 that the loop iteration values are accessed in each index. The loop
4319 indices are then sorted to minimize access to later indices from inner
4322 /* Type for holding index information. */
4326 gfc_forall_iterator
*fa
;
4328 int n
[GFC_MAX_DIMENSIONS
];
4331 /* Callback function to determine if an expression is the
4332 corresponding variable. */
4335 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4337 gfc_expr
*expr
= *e
;
4340 if (expr
->expr_type
!= EXPR_VARIABLE
)
4343 sym
= (gfc_symbol
*) data
;
4344 return sym
== expr
->symtree
->n
.sym
;
4347 /* Callback function to calculate the cost of a certain index. */
4350 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4360 if (expr
->expr_type
!= EXPR_VARIABLE
)
4364 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4366 if (ref
->type
== REF_ARRAY
)
4372 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4375 ind
= (ind_type
*) data
;
4376 for (i
= 0; i
< ar
->dimen
; i
++)
4378 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4380 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4387 /* Callback function for qsort, to sort the loop indices. */
4390 loop_comp (const void *e1
, const void *e2
)
4392 const ind_type
*i1
= (const ind_type
*) e1
;
4393 const ind_type
*i2
= (const ind_type
*) e2
;
4396 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4398 if (i1
->n
[i
] != i2
->n
[i
])
4399 return i1
->n
[i
] - i2
->n
[i
];
4401 /* All other things being equal, let's not change the ordering. */
4402 return i2
->num
- i1
->num
;
4405 /* Main function to do the index interchange. */
4408 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4409 void *data ATTRIBUTE_UNUSED
)
4414 gfc_forall_iterator
*fa
;
4418 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4422 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4425 /* Nothing to reorder. */
4429 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4432 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4434 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4436 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4441 ind
[n_iter
].sym
= NULL
;
4442 ind
[n_iter
].fa
= NULL
;
4444 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4445 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4447 /* Do the actual index interchange. */
4448 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4449 for (i
=1; i
<n_iter
; i
++)
4451 fa
->next
= ind
[i
].fa
;
4456 if (flag_warn_frontend_loop_interchange
)
4458 for (i
=1; i
<n_iter
; i
++)
4460 if (ind
[i
-1].num
> ind
[i
].num
)
4462 gfc_warning (OPT_Wfrontend_loop_interchange
,
4463 "Interchanging loops at %L", &co
->loc
);
4472 #define WALK_SUBEXPR(NODE) \
4475 result = gfc_expr_walker (&(NODE), exprfn, data); \
4480 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4482 /* Walk expression *E, calling EXPRFN on each expression in it. */
4485 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4489 int walk_subtrees
= 1;
4490 gfc_actual_arglist
*a
;
4494 int result
= exprfn (e
, &walk_subtrees
, data
);
4498 switch ((*e
)->expr_type
)
4501 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4502 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4505 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4506 WALK_SUBEXPR (a
->expr
);
4510 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4511 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4512 WALK_SUBEXPR (a
->expr
);
4515 case EXPR_STRUCTURE
:
4517 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4518 c
= gfc_constructor_next (c
))
4520 if (c
->iterator
== NULL
)
4521 WALK_SUBEXPR (c
->expr
);
4525 WALK_SUBEXPR (c
->expr
);
4527 WALK_SUBEXPR (c
->iterator
->var
);
4528 WALK_SUBEXPR (c
->iterator
->start
);
4529 WALK_SUBEXPR (c
->iterator
->end
);
4530 WALK_SUBEXPR (c
->iterator
->step
);
4534 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4537 /* Fall through to the variable case in order to walk the
4541 case EXPR_SUBSTRING
:
4543 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4552 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4554 for (i
=0; i
< ar
->dimen
; i
++)
4556 WALK_SUBEXPR (ar
->start
[i
]);
4557 WALK_SUBEXPR (ar
->end
[i
]);
4558 WALK_SUBEXPR (ar
->stride
[i
]);
4565 WALK_SUBEXPR (r
->u
.ss
.start
);
4566 WALK_SUBEXPR (r
->u
.ss
.end
);
4582 #define WALK_SUBCODE(NODE) \
4585 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4591 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4592 on each expression in it. If any of the hooks returns non-zero, that
4593 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4594 no subcodes or subexpressions are traversed. */
4597 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4600 for (; *c
; c
= &(*c
)->next
)
4602 int walk_subtrees
= 1;
4603 int result
= codefn (c
, &walk_subtrees
, data
);
4610 gfc_actual_arglist
*a
;
4612 gfc_association_list
*alist
;
4613 bool saved_in_omp_workshare
;
4614 bool saved_in_where
;
4616 /* There might be statement insertions before the current code,
4617 which must not affect the expression walker. */
4620 saved_in_omp_workshare
= in_omp_workshare
;
4621 saved_in_where
= in_where
;
4627 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4628 if (co
->ext
.block
.assoc
)
4630 bool saved_in_assoc_list
= in_assoc_list
;
4632 in_assoc_list
= true;
4633 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4634 WALK_SUBEXPR (alist
->target
);
4636 in_assoc_list
= saved_in_assoc_list
;
4643 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4644 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4645 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4646 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4658 case EXEC_ASSIGN_CALL
:
4659 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4660 WALK_SUBEXPR (a
->expr
);
4664 WALK_SUBEXPR (co
->expr1
);
4665 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4666 WALK_SUBEXPR (a
->expr
);
4670 WALK_SUBEXPR (co
->expr1
);
4672 for (b
= co
->block
; b
; b
= b
->block
)
4675 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4677 WALK_SUBEXPR (cp
->low
);
4678 WALK_SUBEXPR (cp
->high
);
4680 WALK_SUBCODE (b
->next
);
4685 case EXEC_DEALLOCATE
:
4688 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4689 WALK_SUBEXPR (a
->expr
);
4694 case EXEC_DO_CONCURRENT
:
4696 gfc_forall_iterator
*fa
;
4697 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4699 WALK_SUBEXPR (fa
->var
);
4700 WALK_SUBEXPR (fa
->start
);
4701 WALK_SUBEXPR (fa
->end
);
4702 WALK_SUBEXPR (fa
->stride
);
4704 if (co
->op
== EXEC_FORALL
)
4710 WALK_SUBEXPR (co
->ext
.open
->unit
);
4711 WALK_SUBEXPR (co
->ext
.open
->file
);
4712 WALK_SUBEXPR (co
->ext
.open
->status
);
4713 WALK_SUBEXPR (co
->ext
.open
->access
);
4714 WALK_SUBEXPR (co
->ext
.open
->form
);
4715 WALK_SUBEXPR (co
->ext
.open
->recl
);
4716 WALK_SUBEXPR (co
->ext
.open
->blank
);
4717 WALK_SUBEXPR (co
->ext
.open
->position
);
4718 WALK_SUBEXPR (co
->ext
.open
->action
);
4719 WALK_SUBEXPR (co
->ext
.open
->delim
);
4720 WALK_SUBEXPR (co
->ext
.open
->pad
);
4721 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4722 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4723 WALK_SUBEXPR (co
->ext
.open
->convert
);
4724 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4725 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4726 WALK_SUBEXPR (co
->ext
.open
->round
);
4727 WALK_SUBEXPR (co
->ext
.open
->sign
);
4728 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4729 WALK_SUBEXPR (co
->ext
.open
->id
);
4730 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4731 WALK_SUBEXPR (co
->ext
.open
->share
);
4732 WALK_SUBEXPR (co
->ext
.open
->cc
);
4736 WALK_SUBEXPR (co
->ext
.close
->unit
);
4737 WALK_SUBEXPR (co
->ext
.close
->status
);
4738 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4739 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4742 case EXEC_BACKSPACE
:
4746 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4747 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4748 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4752 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4753 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4754 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4755 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4756 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4757 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4758 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4759 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4760 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4761 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4762 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4763 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4764 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4765 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4766 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4767 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4768 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4769 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4770 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4771 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4772 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4773 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4774 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4775 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4776 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4777 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4778 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4779 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4780 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4781 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4782 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4783 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4784 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4785 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4786 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4787 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4791 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4792 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4793 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4794 WALK_SUBEXPR (co
->ext
.wait
->id
);
4799 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4800 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4801 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4802 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4803 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4804 WALK_SUBEXPR (co
->ext
.dt
->size
);
4805 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4806 WALK_SUBEXPR (co
->ext
.dt
->id
);
4807 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4808 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4809 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4810 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4811 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4812 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4813 WALK_SUBEXPR (co
->ext
.dt
->round
);
4814 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4815 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4818 case EXEC_OMP_PARALLEL
:
4819 case EXEC_OMP_PARALLEL_DO
:
4820 case EXEC_OMP_PARALLEL_DO_SIMD
:
4821 case EXEC_OMP_PARALLEL_SECTIONS
:
4823 in_omp_workshare
= false;
4825 /* This goto serves as a shortcut to avoid code
4826 duplication or a larger if or switch statement. */
4827 goto check_omp_clauses
;
4829 case EXEC_OMP_WORKSHARE
:
4830 case EXEC_OMP_PARALLEL_WORKSHARE
:
4832 in_omp_workshare
= true;
4836 case EXEC_OMP_CRITICAL
:
4837 case EXEC_OMP_DISTRIBUTE
:
4838 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4839 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4840 case EXEC_OMP_DISTRIBUTE_SIMD
:
4842 case EXEC_OMP_DO_SIMD
:
4843 case EXEC_OMP_ORDERED
:
4844 case EXEC_OMP_SECTIONS
:
4845 case EXEC_OMP_SINGLE
:
4846 case EXEC_OMP_END_SINGLE
:
4848 case EXEC_OMP_TASKLOOP
:
4849 case EXEC_OMP_TASKLOOP_SIMD
:
4850 case EXEC_OMP_TARGET
:
4851 case EXEC_OMP_TARGET_DATA
:
4852 case EXEC_OMP_TARGET_ENTER_DATA
:
4853 case EXEC_OMP_TARGET_EXIT_DATA
:
4854 case EXEC_OMP_TARGET_PARALLEL
:
4855 case EXEC_OMP_TARGET_PARALLEL_DO
:
4856 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4857 case EXEC_OMP_TARGET_SIMD
:
4858 case EXEC_OMP_TARGET_TEAMS
:
4859 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4860 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4861 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4862 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4863 case EXEC_OMP_TARGET_UPDATE
:
4865 case EXEC_OMP_TEAMS
:
4866 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4867 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4868 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4869 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4871 /* Come to this label only from the
4872 EXEC_OMP_PARALLEL_* cases above. */
4876 if (co
->ext
.omp_clauses
)
4878 gfc_omp_namelist
*n
;
4879 static int list_types
[]
4880 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4881 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4883 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4884 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4885 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4886 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4887 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4888 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4889 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4890 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4891 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4892 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4893 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4894 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4895 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4896 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4897 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4898 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4900 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4902 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4904 WALK_SUBEXPR (n
->expr
);
4911 WALK_SUBEXPR (co
->expr1
);
4912 WALK_SUBEXPR (co
->expr2
);
4913 WALK_SUBEXPR (co
->expr3
);
4914 WALK_SUBEXPR (co
->expr4
);
4915 for (b
= co
->block
; b
; b
= b
->block
)
4917 WALK_SUBEXPR (b
->expr1
);
4918 WALK_SUBEXPR (b
->expr2
);
4919 WALK_SUBCODE (b
->next
);
4922 if (co
->op
== EXEC_FORALL
)
4925 if (co
->op
== EXEC_DO
)
4928 if (co
->op
== EXEC_IF
)
4931 if (co
->op
== EXEC_SELECT
)
4934 in_omp_workshare
= saved_in_omp_workshare
;
4935 in_where
= saved_in_where
;