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
)
843 if (e
->expr_type
!= EXPR_FUNCTION
)
845 if (e
->value
.function
.esym
)
846 gfc_warning (OPT_Wfunction_elimination
,
847 "Removing call to function %qs at %L",
848 e
->value
.function
.esym
->name
, &(e
->where
));
849 else if (e
->value
.function
.isym
)
850 gfc_warning (OPT_Wfunction_elimination
,
851 "Removing call to function %qs at %L",
852 e
->value
.function
.isym
->name
, &(e
->where
));
854 /* Callback function for the code walker for doing common function
855 elimination. This builds up the list of functions in the expression
856 and goes through them to detect duplicates, which it then replaces
860 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
861 void *data ATTRIBUTE_UNUSED
)
867 /* Don't do this optimization within OMP workshare or ASSOC lists. */
869 if (in_omp_workshare
|| in_assoc_list
)
875 expr_array
.release ();
877 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
879 /* Walk through all the functions. */
881 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
883 /* Skip if the function has been replaced by a variable already. */
884 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
891 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
894 newvar
= create_var (*ei
, "fcn");
896 if (warn_function_elimination
)
897 do_warn_function_elimination (*ej
);
900 *ej
= gfc_copy_expr (newvar
);
907 /* We did all the necessary walking in this function. */
912 /* Callback function for common function elimination, called from
913 gfc_code_walker. This keeps track of the current code, in order
914 to insert statements as needed. */
917 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
920 inserted_block
= NULL
;
921 changed_statement
= NULL
;
923 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
924 and allocation on assigment are prohibited inside WHERE, and finally
925 masking an expression would lead to wrong-code when replacing
928 b = sum(foo(a) + foo(a))
939 if ((*c
)->op
== EXEC_WHERE
)
949 /* Dummy function for expression call back, for use when we
950 really don't want to do any walking. */
953 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
954 void *data ATTRIBUTE_UNUSED
)
960 /* Dummy function for code callback, for use when we really
961 don't want to do anything. */
963 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
964 int *walk_subtrees ATTRIBUTE_UNUSED
,
965 void *data ATTRIBUTE_UNUSED
)
970 /* Code callback function for converting
977 This is because common function elimination would otherwise place the
978 temporary variables outside the loop. */
981 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
982 void *data ATTRIBUTE_UNUSED
)
985 gfc_code
*c_if1
, *c_if2
, *c_exit
;
987 gfc_expr
*e_not
, *e_cond
;
989 if (co
->op
!= EXEC_DO_WHILE
)
992 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
997 /* Generate the condition of the if statement, which is .not. the original
999 e_not
= gfc_get_expr ();
1000 e_not
->ts
= e_cond
->ts
;
1001 e_not
->where
= e_cond
->where
;
1002 e_not
->expr_type
= EXPR_OP
;
1003 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1004 e_not
->value
.op
.op1
= e_cond
;
1006 /* Generate the EXIT statement. */
1007 c_exit
= XCNEW (gfc_code
);
1008 c_exit
->op
= EXEC_EXIT
;
1009 c_exit
->ext
.which_construct
= co
;
1010 c_exit
->loc
= co
->loc
;
1012 /* Generate the IF statement. */
1013 c_if2
= XCNEW (gfc_code
);
1014 c_if2
->op
= EXEC_IF
;
1015 c_if2
->expr1
= e_not
;
1016 c_if2
->next
= c_exit
;
1017 c_if2
->loc
= co
->loc
;
1019 /* ... plus the one to chain it to. */
1020 c_if1
= XCNEW (gfc_code
);
1021 c_if1
->op
= EXEC_IF
;
1022 c_if1
->block
= c_if2
;
1023 c_if1
->loc
= co
->loc
;
1025 /* Make the DO WHILE loop into a DO block by replacing the condition
1026 with a true constant. */
1027 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1029 /* Hang the generated if statement into the loop body. */
1031 loopblock
= co
->block
->next
;
1032 co
->block
->next
= c_if1
;
1033 c_if1
->next
= loopblock
;
1038 /* Code callback function for converting
1051 because otherwise common function elimination would place the BLOCKs
1052 into the wrong place. */
1055 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1056 void *data ATTRIBUTE_UNUSED
)
1059 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1061 if (co
->op
!= EXEC_IF
)
1064 /* This loop starts out with the first ELSE statement. */
1065 else_stmt
= co
->block
->block
;
1067 while (else_stmt
!= NULL
)
1069 gfc_code
*next_else
;
1071 /* If there is no condition, we're done. */
1072 if (else_stmt
->expr1
== NULL
)
1075 next_else
= else_stmt
->block
;
1077 /* Generate the new IF statement. */
1078 c_if2
= XCNEW (gfc_code
);
1079 c_if2
->op
= EXEC_IF
;
1080 c_if2
->expr1
= else_stmt
->expr1
;
1081 c_if2
->next
= else_stmt
->next
;
1082 c_if2
->loc
= else_stmt
->loc
;
1083 c_if2
->block
= next_else
;
1085 /* ... plus the one to chain it to. */
1086 c_if1
= XCNEW (gfc_code
);
1087 c_if1
->op
= EXEC_IF
;
1088 c_if1
->block
= c_if2
;
1089 c_if1
->loc
= else_stmt
->loc
;
1091 /* Insert the new IF after the ELSE. */
1092 else_stmt
->expr1
= NULL
;
1093 else_stmt
->next
= c_if1
;
1094 else_stmt
->block
= NULL
;
1096 else_stmt
= next_else
;
1098 /* Don't walk subtrees. */
1104 struct do_stack
*prev
;
1109 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1110 optimize by replacing do loops with their analog array slices. For
1113 write (*,*) (a(i), i=1,4)
1117 write (*,*) a(1:4:1) . */
1120 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1123 gfc_expr
*new_e
, *expr
, *start
;
1125 struct do_stack ds_push
;
1126 int i
, future_rank
= 0;
1127 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1130 /* Find the first transfer/do statement. */
1131 for (curr
= code
; curr
; curr
= curr
->next
)
1133 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1137 /* Ensure it is the only transfer/do statement because cases like
1139 write (*,*) (a(i), b(i), i=1,4)
1141 cannot be optimized. */
1143 if (!curr
|| curr
->next
)
1146 if (curr
->op
== EXEC_DO
)
1148 if (curr
->ext
.iterator
->var
->ref
)
1150 ds_push
.prev
= stack_top
;
1151 ds_push
.iter
= curr
->ext
.iterator
;
1152 ds_push
.code
= curr
;
1153 stack_top
= &ds_push
;
1154 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1156 if (curr
!= stack_top
->code
&& !*has_reached
)
1158 curr
->block
->next
= NULL
;
1159 gfc_free_statements (curr
);
1162 *has_reached
= true;
1168 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1172 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1175 /* Find the iterators belonging to each variable and check conditions. */
1176 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1178 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1179 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1182 start
= ref
->u
.ar
.start
[i
];
1183 gfc_simplify_expr (start
, 0);
1184 switch (start
->expr_type
)
1188 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1192 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1193 if (!stack_top
|| !stack_top
->iter
1194 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1196 /* Check for (a(i,i), i=1,3). */
1200 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1207 iters
[i
] = stack_top
->iter
;
1208 stack_top
= stack_top
->prev
;
1216 switch (start
->value
.op
.op
)
1218 case INTRINSIC_PLUS
:
1219 case INTRINSIC_TIMES
:
1220 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1221 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1223 case INTRINSIC_MINUS
:
1224 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1225 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1226 || start
->value
.op
.op1
->ref
)
1228 if (!stack_top
|| !stack_top
->iter
1229 || stack_top
->iter
->var
->symtree
1230 != start
->value
.op
.op1
->symtree
)
1232 iters
[i
] = stack_top
->iter
;
1233 stack_top
= stack_top
->prev
;
1245 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1246 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1250 gfc_expr
*var
= iters
[i
]->var
;
1251 for (int j
= i
- 1; j
< i
; j
++)
1254 && (gfc_check_dependency (var
, iters
[j
]->start
, true)
1255 || gfc_check_dependency (var
, iters
[j
]->end
, true)
1256 || gfc_check_dependency (var
, iters
[j
]->step
, true)))
1262 /* Create new expr. */
1263 new_e
= gfc_copy_expr (curr
->expr1
);
1264 new_e
->expr_type
= EXPR_VARIABLE
;
1265 new_e
->rank
= future_rank
;
1266 if (curr
->expr1
->shape
)
1267 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1269 /* Assign new starts, ends and strides if necessary. */
1270 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1274 start
= ref
->u
.ar
.start
[i
];
1275 switch (start
->expr_type
)
1278 gfc_internal_error ("bad expression");
1281 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1282 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1283 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1284 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1285 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1286 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1289 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1290 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1291 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1292 expr
= gfc_copy_expr (start
);
1293 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1294 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1295 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1296 expr
= gfc_copy_expr (start
);
1297 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1298 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1299 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1300 switch (start
->value
.op
.op
)
1302 case INTRINSIC_MINUS
:
1303 case INTRINSIC_PLUS
:
1304 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1306 case INTRINSIC_TIMES
:
1307 expr
= gfc_copy_expr (start
);
1308 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1309 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1310 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1313 gfc_internal_error ("bad op");
1317 gfc_internal_error ("bad expression");
1320 curr
->expr1
= new_e
;
1322 /* Insert modified statement. Check whether the statement needs to be
1323 inserted at the lowest level. */
1324 if (!stack_top
->iter
)
1328 curr
->next
= prev
->next
->next
;
1333 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1334 stack_top
->code
->block
->next
= curr
;
1338 stack_top
->code
->block
->next
= curr
;
1342 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1343 tries to optimize its block. */
1346 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1347 void *data ATTRIBUTE_UNUSED
)
1349 gfc_code
**curr
, *prev
= NULL
;
1350 struct do_stack write
, first
;
1354 || ((*code
)->block
->op
!= EXEC_WRITE
1355 && (*code
)->block
->op
!= EXEC_READ
))
1363 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1365 if ((*curr
)->op
== EXEC_DO
)
1367 first
.prev
= &write
;
1368 first
.iter
= (*curr
)->ext
.iterator
;
1371 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1379 /* Optimize a namespace, including all contained namespaces.
1380 flag_frontend_optimize and flag_fronend_loop_interchange are
1381 handled separately. */
1384 optimize_namespace (gfc_namespace
*ns
)
1386 gfc_namespace
*saved_ns
= gfc_current_ns
;
1388 gfc_current_ns
= ns
;
1391 in_assoc_list
= false;
1392 in_omp_workshare
= false;
1394 if (flag_frontend_optimize
)
1396 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1397 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1398 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1399 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1400 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1401 if (flag_inline_matmul_limit
!= 0)
1407 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1412 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1414 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1419 if (flag_frontend_loop_interchange
)
1420 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1423 /* BLOCKs are handled in the expression walker below. */
1424 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1426 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1427 optimize_namespace (ns
);
1429 gfc_current_ns
= saved_ns
;
1432 /* Handle dependencies for allocatable strings which potentially redefine
1433 themselves in an assignment. */
1436 realloc_strings (gfc_namespace
*ns
)
1439 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1441 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1443 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1444 realloc_strings (ns
);
1450 optimize_reduction (gfc_namespace
*ns
)
1453 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1454 callback_reduction
, NULL
);
1456 /* BLOCKs are handled in the expression walker below. */
1457 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1459 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1460 optimize_reduction (ns
);
1464 /* Replace code like
1467 a = matmul(b,c) ; a = a + d
1468 where the array function is not elemental and not allocatable
1469 and does not depend on the left-hand side.
1473 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1481 if (e
->expr_type
== EXPR_OP
)
1483 switch (e
->value
.op
.op
)
1485 /* Unary operators and exponentiation: Only look at a single
1488 case INTRINSIC_UPLUS
:
1489 case INTRINSIC_UMINUS
:
1490 case INTRINSIC_PARENTHESES
:
1491 case INTRINSIC_POWER
:
1492 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1496 case INTRINSIC_CONCAT
:
1497 /* Do not do string concatenations. */
1501 /* Binary operators. */
1502 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1505 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1511 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1512 && ! (e
->value
.function
.esym
1513 && (e
->value
.function
.esym
->attr
.elemental
1514 || e
->value
.function
.esym
->attr
.allocatable
1515 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1516 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1517 && ! (e
->value
.function
.isym
1518 && (e
->value
.function
.isym
->elemental
1519 || e
->ts
.type
!= c
->expr1
->ts
.type
1520 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1521 && ! gfc_inline_intrinsic_function_p (e
))
1527 /* Insert a new assignment statement after the current one. */
1528 n
= XCNEW (gfc_code
);
1529 n
->op
= EXEC_ASSIGN
;
1534 n
->expr1
= gfc_copy_expr (c
->expr1
);
1535 n
->expr2
= c
->expr2
;
1536 new_expr
= gfc_copy_expr (c
->expr1
);
1544 /* Nothing to optimize. */
1548 /* Remove unneeded TRIMs at the end of expressions. */
1551 remove_trim (gfc_expr
*rhs
)
1559 /* Check for a // b // trim(c). Looping is probably not
1560 necessary because the parser usually generates
1561 (// (// a b ) trim(c) ) , but better safe than sorry. */
1563 while (rhs
->expr_type
== EXPR_OP
1564 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1565 rhs
= rhs
->value
.op
.op2
;
1567 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1568 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1570 strip_function_call (rhs
);
1571 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1579 /* Optimizations for an assignment. */
1582 optimize_assignment (gfc_code
* c
)
1584 gfc_expr
*lhs
, *rhs
;
1589 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1591 /* Optimize a = trim(b) to a = b. */
1594 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1595 if (is_empty_string (rhs
))
1596 rhs
->value
.character
.length
= 0;
1599 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1600 optimize_binop_array_assignment (c
, &rhs
, false);
1604 /* Remove an unneeded function call, modifying the expression.
1605 This replaces the function call with the value of its
1606 first argument. The rest of the argument list is freed. */
1609 strip_function_call (gfc_expr
*e
)
1612 gfc_actual_arglist
*a
;
1614 a
= e
->value
.function
.actual
;
1616 /* We should have at least one argument. */
1617 gcc_assert (a
->expr
!= NULL
);
1621 /* Free the remaining arglist, if any. */
1623 gfc_free_actual_arglist (a
->next
);
1625 /* Graft the argument expression onto the original function. */
1631 /* Optimization of lexical comparison functions. */
1634 optimize_lexical_comparison (gfc_expr
*e
)
1636 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1639 switch (e
->value
.function
.isym
->id
)
1642 return optimize_comparison (e
, INTRINSIC_LE
);
1645 return optimize_comparison (e
, INTRINSIC_GE
);
1648 return optimize_comparison (e
, INTRINSIC_GT
);
1651 return optimize_comparison (e
, INTRINSIC_LT
);
1659 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1660 do CHARACTER because of possible pessimization involving character
1664 combine_array_constructor (gfc_expr
*e
)
1667 gfc_expr
*op1
, *op2
;
1670 gfc_constructor
*c
, *new_c
;
1671 gfc_constructor_base oldbase
, newbase
;
1676 /* Array constructors have rank one. */
1680 /* Don't try to combine association lists, this makes no sense
1681 and leads to an ICE. */
1685 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1686 if (forall_level
> 0)
1689 /* Inside an iterator, things can get hairy; we are likely to create
1690 an invalid temporary variable. */
1691 if (iterator_level
> 0)
1694 op1
= e
->value
.op
.op1
;
1695 op2
= e
->value
.op
.op2
;
1700 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1701 scalar_first
= false;
1702 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1704 scalar_first
= true;
1705 op1
= e
->value
.op
.op2
;
1706 op2
= e
->value
.op
.op1
;
1711 if (op2
->ts
.type
== BT_CHARACTER
)
1714 /* This might be an expanded constructor with very many constant values. If
1715 we perform the operation here, we might end up with a long compile time
1716 and actually longer execution time, so a length bound is in order here.
1717 If the constructor constains something which is not a constant, it did
1718 not come from an expansion, so leave it alone. */
1720 #define CONSTR_LEN_MAX 4
1722 oldbase
= op1
->value
.constructor
;
1726 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1728 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1736 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1739 #undef CONSTR_LEN_MAX
1742 e
->expr_type
= EXPR_ARRAY
;
1744 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1746 for (c
= gfc_constructor_first (oldbase
); c
;
1747 c
= gfc_constructor_next (c
))
1749 new_expr
= gfc_get_expr ();
1750 new_expr
->ts
= e
->ts
;
1751 new_expr
->expr_type
= EXPR_OP
;
1752 new_expr
->rank
= c
->expr
->rank
;
1753 new_expr
->where
= c
->expr
->where
;
1754 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1758 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1759 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1763 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1764 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1767 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1768 new_c
->iterator
= c
->iterator
;
1772 gfc_free_expr (op1
);
1773 gfc_free_expr (op2
);
1774 gfc_free_expr (scalar
);
1776 e
->value
.constructor
= newbase
;
1780 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1781 2**k into ishift(1,k) */
1784 optimize_power (gfc_expr
*e
)
1786 gfc_expr
*op1
, *op2
;
1787 gfc_expr
*iand
, *ishft
;
1789 if (e
->ts
.type
!= BT_INTEGER
)
1792 op1
= e
->value
.op
.op1
;
1794 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1797 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1799 gfc_free_expr (op1
);
1801 op2
= e
->value
.op
.op2
;
1806 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1807 "_internal_iand", e
->where
, 2, op2
,
1808 gfc_get_int_expr (e
->ts
.kind
,
1811 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1812 "_internal_ishft", e
->where
, 2, iand
,
1813 gfc_get_int_expr (e
->ts
.kind
,
1816 e
->value
.op
.op
= INTRINSIC_MINUS
;
1817 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1818 e
->value
.op
.op2
= ishft
;
1821 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1823 gfc_free_expr (op1
);
1825 op2
= e
->value
.op
.op2
;
1829 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1830 "_internal_ishft", e
->where
, 2,
1831 gfc_get_int_expr (e
->ts
.kind
,
1838 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1840 op2
= e
->value
.op
.op2
;
1844 gfc_free_expr (op1
);
1845 gfc_free_expr (op2
);
1847 e
->expr_type
= EXPR_CONSTANT
;
1848 e
->value
.op
.op1
= NULL
;
1849 e
->value
.op
.op2
= NULL
;
1850 mpz_init_set_si (e
->value
.integer
, 1);
1851 /* Typespec and location are still OK. */
1858 /* Recursive optimization of operators. */
1861 optimize_op (gfc_expr
*e
)
1865 gfc_intrinsic_op op
= e
->value
.op
.op
;
1869 /* Only use new-style comparisons. */
1872 case INTRINSIC_EQ_OS
:
1876 case INTRINSIC_GE_OS
:
1880 case INTRINSIC_LE_OS
:
1884 case INTRINSIC_NE_OS
:
1888 case INTRINSIC_GT_OS
:
1892 case INTRINSIC_LT_OS
:
1908 changed
= optimize_comparison (e
, op
);
1911 /* Look at array constructors. */
1912 case INTRINSIC_PLUS
:
1913 case INTRINSIC_MINUS
:
1914 case INTRINSIC_TIMES
:
1915 case INTRINSIC_DIVIDE
:
1916 return combine_array_constructor (e
) || changed
;
1918 case INTRINSIC_POWER
:
1919 return optimize_power (e
);
1929 /* Return true if a constant string contains only blanks. */
1932 is_empty_string (gfc_expr
*e
)
1936 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1939 for (i
=0; i
< e
->value
.character
.length
; i
++)
1941 if (e
->value
.character
.string
[i
] != ' ')
1949 /* Insert a call to the intrinsic len_trim. Use a different name for
1950 the symbol tree so we don't run into trouble when the user has
1951 renamed len_trim for some reason. */
1954 get_len_trim_call (gfc_expr
*str
, int kind
)
1957 gfc_actual_arglist
*actual_arglist
, *next
;
1959 fcn
= gfc_get_expr ();
1960 fcn
->expr_type
= EXPR_FUNCTION
;
1961 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1962 actual_arglist
= gfc_get_actual_arglist ();
1963 actual_arglist
->expr
= str
;
1964 next
= gfc_get_actual_arglist ();
1965 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1966 actual_arglist
->next
= next
;
1968 fcn
->value
.function
.actual
= actual_arglist
;
1969 fcn
->where
= str
->where
;
1970 fcn
->ts
.type
= BT_INTEGER
;
1971 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1973 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1974 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1975 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1976 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1977 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1978 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1979 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1980 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1985 /* Optimize expressions for equality. */
1988 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1990 gfc_expr
*op1
, *op2
;
1994 gfc_actual_arglist
*firstarg
, *secondarg
;
1996 if (e
->expr_type
== EXPR_OP
)
2000 op1
= e
->value
.op
.op1
;
2001 op2
= e
->value
.op
.op2
;
2003 else if (e
->expr_type
== EXPR_FUNCTION
)
2005 /* One of the lexical comparison functions. */
2006 firstarg
= e
->value
.function
.actual
;
2007 secondarg
= firstarg
->next
;
2008 op1
= firstarg
->expr
;
2009 op2
= secondarg
->expr
;
2014 /* Strip off unneeded TRIM calls from string comparisons. */
2016 change
= remove_trim (op1
);
2018 if (remove_trim (op2
))
2021 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2022 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2023 handles them well). However, there are also cases that need a non-scalar
2024 argument. For example the any intrinsic. See PR 45380. */
2028 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2030 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2031 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2033 bool empty_op1
, empty_op2
;
2034 empty_op1
= is_empty_string (op1
);
2035 empty_op2
= is_empty_string (op2
);
2037 if (empty_op1
|| empty_op2
)
2043 /* This can only happen when an error for comparing
2044 characters of different kinds has already been issued. */
2045 if (empty_op1
&& empty_op2
)
2048 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2049 str
= empty_op1
? op2
: op1
;
2051 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2055 gfc_free_expr (op1
);
2057 gfc_free_expr (op2
);
2061 e
->value
.op
.op1
= fcn
;
2062 e
->value
.op
.op2
= zero
;
2067 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2069 if (flag_finite_math_only
2070 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2071 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2073 eq
= gfc_dep_compare_expr (op1
, op2
);
2076 /* Replace A // B < A // C with B < C, and A // B < C // B
2078 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2079 && op1
->expr_type
== EXPR_OP
2080 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2081 && op2
->expr_type
== EXPR_OP
2082 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2084 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2085 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2086 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2087 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2089 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2091 /* Watch out for 'A ' // x vs. 'A' // x. */
2093 if (op1_left
->expr_type
== EXPR_CONSTANT
2094 && op2_left
->expr_type
== EXPR_CONSTANT
2095 && op1_left
->value
.character
.length
2096 != op2_left
->value
.character
.length
)
2104 firstarg
->expr
= op1_right
;
2105 secondarg
->expr
= op2_right
;
2109 e
->value
.op
.op1
= op1_right
;
2110 e
->value
.op
.op2
= op2_right
;
2112 optimize_comparison (e
, op
);
2116 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2122 firstarg
->expr
= op1_left
;
2123 secondarg
->expr
= op2_left
;
2127 e
->value
.op
.op1
= op1_left
;
2128 e
->value
.op
.op2
= op2_left
;
2131 optimize_comparison (e
, op
);
2138 /* eq can only be -1, 0 or 1 at this point. */
2166 gfc_internal_error ("illegal OP in optimize_comparison");
2170 /* Replace the expression by a constant expression. The typespec
2171 and where remains the way it is. */
2174 e
->expr_type
= EXPR_CONSTANT
;
2175 e
->value
.logical
= result
;
2183 /* Optimize a trim function by replacing it with an equivalent substring
2184 involving a call to len_trim. This only works for expressions where
2185 variables are trimmed. Return true if anything was modified. */
2188 optimize_trim (gfc_expr
*e
)
2193 gfc_ref
**rr
= NULL
;
2195 /* Don't do this optimization within an argument list, because
2196 otherwise aliasing issues may occur. */
2198 if (count_arglist
!= 1)
2201 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2202 || e
->value
.function
.isym
== NULL
2203 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2206 a
= e
->value
.function
.actual
->expr
;
2208 if (a
->expr_type
!= EXPR_VARIABLE
)
2211 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2213 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2216 /* Follow all references to find the correct place to put the newly
2217 created reference. FIXME: Also handle substring references and
2218 array references. Array references cause strange regressions at
2223 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2225 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2230 strip_function_call (e
);
2235 /* Create the reference. */
2237 ref
= gfc_get_ref ();
2238 ref
->type
= REF_SUBSTRING
;
2240 /* Set the start of the reference. */
2242 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2244 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2246 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2248 /* Set the end of the reference to the call to len_trim. */
2250 ref
->u
.ss
.end
= fcn
;
2251 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2256 /* Optimize minloc(b), where b is rank 1 array, into
2257 (/ minloc(b, dim=1) /), and similarly for maxloc,
2258 as the latter forms are expanded inline. */
2261 optimize_minmaxloc (gfc_expr
**e
)
2264 gfc_actual_arglist
*a
;
2268 || fn
->value
.function
.actual
== NULL
2269 || fn
->value
.function
.actual
->expr
== NULL
2270 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2273 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2274 (*e
)->shape
= fn
->shape
;
2277 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2279 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2280 strcpy (name
, fn
->value
.function
.name
);
2281 p
= strstr (name
, "loc0");
2283 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2284 if (fn
->value
.function
.actual
->next
)
2286 a
= fn
->value
.function
.actual
->next
;
2287 gcc_assert (a
->expr
== NULL
);
2291 a
= gfc_get_actual_arglist ();
2292 fn
->value
.function
.actual
->next
= a
;
2294 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2296 mpz_set_ui (a
->expr
->value
.integer
, 1);
2299 /* Callback function for code checking that we do not pass a DO variable to an
2300 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2303 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2304 void *data ATTRIBUTE_UNUSED
)
2308 gfc_formal_arglist
*f
;
2309 gfc_actual_arglist
*a
;
2316 /* If the doloop_list grew, we have to truncate it here. */
2318 if ((unsigned) doloop_level
< doloop_list
.length())
2319 doloop_list
.truncate (doloop_level
);
2326 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2331 loop
.branch_level
= if_level
+ select_level
;
2332 loop
.seen_goto
= false;
2333 doloop_list
.safe_push (loop
);
2336 /* If anything could transfer control away from a suspicious
2337 subscript, make sure to set seen_goto in the current DO loop
2342 case EXEC_ERROR_STOP
:
2348 if (co
->ext
.open
->err
)
2353 if (co
->ext
.close
->err
)
2357 case EXEC_BACKSPACE
:
2362 if (co
->ext
.filepos
->err
)
2367 if (co
->ext
.filepos
->err
)
2373 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2378 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2379 loop
.seen_goto
= true;
2384 if (co
->resolved_sym
== NULL
)
2387 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2389 /* Withot a formal arglist, there is only unknown INTENT,
2390 which we don't check for. */
2398 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2406 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2408 if (a
->expr
&& a
->expr
->symtree
2409 && a
->expr
->symtree
->n
.sym
== do_sym
)
2411 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2412 gfc_error_now ("Variable %qs at %L set to undefined "
2413 "value inside loop beginning at %L as "
2414 "INTENT(OUT) argument to subroutine %qs",
2415 do_sym
->name
, &a
->expr
->where
,
2416 &(doloop_list
[i
].c
->loc
),
2417 co
->symtree
->n
.sym
->name
);
2418 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2419 gfc_error_now ("Variable %qs at %L not definable inside "
2420 "loop beginning at %L as INTENT(INOUT) "
2421 "argument to subroutine %qs",
2422 do_sym
->name
, &a
->expr
->where
,
2423 &(doloop_list
[i
].c
->loc
),
2424 co
->symtree
->n
.sym
->name
);
2435 if (seen_goto
&& doloop_level
> 0)
2436 doloop_list
[doloop_level
-1].seen_goto
= true;
2441 /* Callback function to warn about different things within DO loops. */
2444 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2445 void *data ATTRIBUTE_UNUSED
)
2449 if (doloop_list
.length () == 0)
2452 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2455 last
= &doloop_list
.last();
2456 if (last
->seen_goto
&& !warn_do_subscript
)
2459 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2471 /* Callback function - if the expression is the variable in data->sym,
2472 replace it with a constant from data->val. */
2475 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2482 if (ex
->expr_type
!= EXPR_VARIABLE
)
2485 d
= (insert_index_t
*) data
;
2486 if (ex
->symtree
->n
.sym
!= d
->sym
)
2489 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2490 mpz_set (n
->value
.integer
, d
->val
);
2497 /* In the expression e, replace occurrences of the variable sym with
2498 val. If this results in a constant expression, return true and
2499 return the value in ret. Return false if the expression already
2500 is a constant. Caller has to clear ret in that case. */
2503 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2506 insert_index_t data
;
2509 if (e
->expr_type
== EXPR_CONSTANT
)
2512 n
= gfc_copy_expr (e
);
2514 mpz_init_set (data
.val
, val
);
2515 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2516 gfc_simplify_expr (n
, 0);
2518 if (n
->expr_type
== EXPR_CONSTANT
)
2521 mpz_init_set (ret
, n
->value
.integer
);
2526 mpz_clear (data
.val
);
2532 /* Check array subscripts for possible out-of-bounds accesses in DO
2533 loops with constant bounds. */
2536 do_subscript (gfc_expr
**e
)
2546 /* Constants are already checked. */
2547 if (v
->expr_type
== EXPR_CONSTANT
)
2550 /* Wrong warnings will be generated in an associate list. */
2554 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2556 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2559 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2562 mpz_t do_start
, do_step
, do_end
;
2563 bool have_do_start
, have_do_end
;
2564 bool error_not_proven
;
2571 /* If we are within a branch, or a goto or equivalent
2572 was seen in the DO loop before, then we cannot prove that
2573 this expression is actually evaluated. Don't do anything
2574 unless we want to see it all. */
2575 error_not_proven
= lp
->seen_goto
2576 || lp
->branch_level
< if_level
+ select_level
;
2578 if (error_not_proven
&& !warn_do_subscript
)
2581 if (error_not_proven
)
2582 warn
= OPT_Wdo_subscript
;
2586 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2587 if (do_sym
->ts
.type
!= BT_INTEGER
)
2590 /* If we do not know about the stepsize, the loop may be zero trip.
2591 Do not warn in this case. */
2593 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2594 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2598 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2600 have_do_start
= true;
2601 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2604 have_do_start
= false;
2607 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2610 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2613 have_do_end
= false;
2615 if (!have_do_start
&& !have_do_end
)
2618 /* May have to correct the end value if the step does not equal
2620 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2626 mpz_sub (diff
, do_end
, do_start
);
2627 mpz_tdiv_r (rem
, diff
, do_step
);
2628 mpz_sub (do_end
, do_end
, rem
);
2633 for (i
= 0; i
< ar
->dimen
; i
++)
2636 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2637 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2639 if (ar
->as
->lower
[i
]
2640 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2641 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2642 gfc_warning (warn
, "Array reference at %L out of bounds "
2643 "(%ld < %ld) in loop beginning at %L",
2644 &ar
->start
[i
]->where
, mpz_get_si (val
),
2645 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2646 &doloop_list
[j
].c
->loc
);
2648 if (ar
->as
->upper
[i
]
2649 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2650 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2651 gfc_warning (warn
, "Array reference at %L out of bounds "
2652 "(%ld > %ld) in loop beginning at %L",
2653 &ar
->start
[i
]->where
, mpz_get_si (val
),
2654 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2655 &doloop_list
[j
].c
->loc
);
2660 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2661 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2663 if (ar
->as
->lower
[i
]
2664 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2665 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2666 gfc_warning (warn
, "Array reference at %L out of bounds "
2667 "(%ld < %ld) in loop beginning at %L",
2668 &ar
->start
[i
]->where
, mpz_get_si (val
),
2669 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2670 &doloop_list
[j
].c
->loc
);
2672 if (ar
->as
->upper
[i
]
2673 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2674 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2675 gfc_warning (warn
, "Array reference at %L out of bounds "
2676 "(%ld > %ld) in loop beginning at %L",
2677 &ar
->start
[i
]->where
, mpz_get_si (val
),
2678 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2679 &doloop_list
[j
].c
->loc
);
2689 /* Function for functions checking that we do not pass a DO variable
2690 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2693 do_intent (gfc_expr
**e
)
2695 gfc_formal_arglist
*f
;
2696 gfc_actual_arglist
*a
;
2703 if (expr
->expr_type
!= EXPR_FUNCTION
)
2706 /* Intrinsic functions don't modify their arguments. */
2708 if (expr
->value
.function
.isym
)
2711 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2713 /* Without a formal arglist, there is only unknown INTENT,
2714 which we don't check for. */
2718 a
= expr
->value
.function
.actual
;
2722 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2729 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2731 if (a
->expr
&& a
->expr
->symtree
2732 && a
->expr
->symtree
->n
.sym
== do_sym
)
2734 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2735 gfc_error_now ("Variable %qs at %L set to undefined value "
2736 "inside loop beginning at %L as INTENT(OUT) "
2737 "argument to function %qs", do_sym
->name
,
2738 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2739 expr
->symtree
->n
.sym
->name
);
2740 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2741 gfc_error_now ("Variable %qs at %L not definable inside loop"
2742 " beginning at %L as INTENT(INOUT) argument to"
2743 " function %qs", do_sym
->name
,
2744 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2745 expr
->symtree
->n
.sym
->name
);
2756 doloop_warn (gfc_namespace
*ns
)
2758 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2761 /* This selction deals with inlining calls to MATMUL. */
2763 /* Replace calls to matmul outside of straight assignments with a temporary
2764 variable so that later inlining will work. */
2767 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2771 bool *found
= (bool *) data
;
2775 if (e
->expr_type
!= EXPR_FUNCTION
2776 || e
->value
.function
.isym
== NULL
2777 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2780 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2781 || in_where
|| in_assoc_list
)
2784 /* Check if this is already in the form c = matmul(a,b). */
2786 if ((*current_code
)->expr2
== e
)
2789 n
= create_var (e
, "matmul");
2791 /* If create_var is unable to create a variable (for example if
2792 -fno-realloc-lhs is in force with a variable that does not have bounds
2793 known at compile-time), just return. */
2803 /* Set current_code and associated variables so that matmul_to_var_expr can
2807 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2808 void *data ATTRIBUTE_UNUSED
)
2810 if (current_code
!= c
)
2813 inserted_block
= NULL
;
2814 changed_statement
= NULL
;
2821 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2822 for a and b if there is a dependency between the arguments and the
2823 result variable or if a or b are the result of calculations that cannot
2824 be handled by the inliner. */
2827 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2828 void *data ATTRIBUTE_UNUSED
)
2830 gfc_expr
*expr1
, *expr2
;
2832 gfc_actual_arglist
*a
, *b
;
2834 gfc_expr
*matrix_a
, *matrix_b
;
2835 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2839 if (co
->op
!= EXEC_ASSIGN
)
2842 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2846 /* This has some duplication with inline_matmul_assign. This
2847 is because the creation of temporary variables could still fail,
2848 and inline_matmul_assign still needs to be able to handle these
2853 if (expr2
->expr_type
!= EXPR_FUNCTION
2854 || expr2
->value
.function
.isym
== NULL
2855 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2859 a
= expr2
->value
.function
.actual
;
2860 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2861 if (matrix_a
!= NULL
)
2863 if (matrix_a
->expr_type
== EXPR_VARIABLE
2864 && (gfc_check_dependency (matrix_a
, expr1
, true)
2865 || has_dimen_vector_ref (matrix_a
)))
2873 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2874 if (matrix_b
!= NULL
)
2876 if (matrix_b
->expr_type
== EXPR_VARIABLE
2877 && (gfc_check_dependency (matrix_b
, expr1
, true)
2878 || has_dimen_vector_ref (matrix_b
)))
2884 if (!a_tmp
&& !b_tmp
)
2888 inserted_block
= NULL
;
2889 changed_statement
= NULL
;
2893 at
= create_var (a
->expr
,"mma");
2900 bt
= create_var (b
->expr
,"mmb");
2907 /* Auxiliary function to build and simplify an array inquiry function.
2908 dim is zero-based. */
2911 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2914 gfc_expr
*dim_arg
, *kind
;
2920 case GFC_ISYM_LBOUND
:
2921 name
= "_gfortran_lbound";
2924 case GFC_ISYM_UBOUND
:
2925 name
= "_gfortran_ubound";
2929 name
= "_gfortran_size";
2936 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2937 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2938 gfc_index_integer_kind
);
2940 ec
= gfc_copy_expr (e
);
2942 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2944 ec
->no_bounds_check
= 1;
2945 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2947 gfc_simplify_expr (fcn
, 0);
2948 fcn
->no_bounds_check
= 1;
2952 /* Builds a logical expression. */
2955 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2960 ts
.type
= BT_LOGICAL
;
2961 ts
.kind
= gfc_default_logical_kind
;
2962 res
= gfc_get_expr ();
2963 res
->where
= e1
->where
;
2964 res
->expr_type
= EXPR_OP
;
2965 res
->value
.op
.op
= op
;
2966 res
->value
.op
.op1
= e1
;
2967 res
->value
.op
.op2
= e2
;
2974 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2975 compatible typespecs. */
2978 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2982 res
= gfc_get_expr ();
2984 res
->where
= e1
->where
;
2985 res
->expr_type
= EXPR_OP
;
2986 res
->value
.op
.op
= op
;
2987 res
->value
.op
.op1
= e1
;
2988 res
->value
.op
.op2
= e2
;
2989 gfc_simplify_expr (res
, 0);
2993 /* Generate the IF statement for a runtime check if we want to do inlining or
2994 not - putting in the code for both branches and putting it into the syntax
2995 tree is the caller's responsibility. For fixed array sizes, this should be
2996 removed by DCE. Only called for rank-two matrices A and B. */
2999 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
3001 gfc_expr
*inline_limit
;
3002 gfc_code
*if_1
, *if_2
, *else_2
;
3003 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3007 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
3009 /* Calculation is done in real to avoid integer overflow. */
3011 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3013 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
3015 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3018 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3019 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3020 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3024 ts
.kind
= gfc_default_real_kind
;
3025 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3026 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3027 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3029 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3030 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3032 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3033 gfc_simplify_expr (cond
, 0);
3035 else_2
= XCNEW (gfc_code
);
3036 else_2
->op
= EXEC_IF
;
3037 else_2
->loc
= a
->where
;
3039 if_2
= XCNEW (gfc_code
);
3042 if_2
->loc
= a
->where
;
3043 if_2
->block
= else_2
;
3045 if_1
= XCNEW (gfc_code
);
3048 if_1
->loc
= a
->where
;
3054 /* Insert code to issue a runtime error if the expressions are not equal. */
3057 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3060 gfc_code
*if_1
, *if_2
;
3062 gfc_actual_arglist
*a1
, *a2
, *a3
;
3064 gcc_assert (e1
->where
.lb
);
3065 /* Build the call to runtime_error. */
3066 c
= XCNEW (gfc_code
);
3070 /* Get a null-terminated message string. */
3072 a1
= gfc_get_actual_arglist ();
3073 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3074 msg
, strlen(msg
)+1);
3077 /* Pass the value of the first expression. */
3078 a2
= gfc_get_actual_arglist ();
3079 a2
->expr
= gfc_copy_expr (e1
);
3082 /* Pass the value of the second expression. */
3083 a3
= gfc_get_actual_arglist ();
3084 a3
->expr
= gfc_copy_expr (e2
);
3087 gfc_check_fe_runtime_error (c
->ext
.actual
);
3088 gfc_resolve_fe_runtime_error (c
);
3090 if_2
= XCNEW (gfc_code
);
3092 if_2
->loc
= e1
->where
;
3095 if_1
= XCNEW (gfc_code
);
3098 if_1
->loc
= e1
->where
;
3100 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3101 gfc_simplify_expr (cond
, 0);
3107 /* Handle matrix reallocation. Caller is responsible to insert into
3110 For the two-dimensional case, build
3112 if (allocated(c)) then
3113 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3115 allocate (c(size(a,1), size(b,2)))
3118 allocate (c(size(a,1),size(b,2)))
3121 and for the other cases correspondingly.
3125 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3126 enum matrix_case m_case
)
3129 gfc_expr
*allocated
, *alloc_expr
;
3130 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3131 gfc_code
*else_alloc
;
3132 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3134 gfc_expr
*cond
, *ne1
, *ne2
;
3136 if (warn_realloc_lhs
)
3137 gfc_warning (OPT_Wrealloc_lhs
,
3138 "Code for reallocating the allocatable array at %L will "
3139 "be added", &c
->where
);
3141 alloc_expr
= gfc_copy_expr (c
);
3143 ar
= gfc_find_array_ref (alloc_expr
);
3144 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3146 /* c comes in as a full ref. Change it into a copy and make it into an
3147 element ref so it has the right form for for ALLOCATE. In the same
3148 switch statement, also generate the size comparison for the secod IF
3151 ar
->type
= AR_ELEMENT
;
3156 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3157 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3158 ne1
= build_logical_expr (INTRINSIC_NE
,
3159 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3160 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3161 ne2
= build_logical_expr (INTRINSIC_NE
,
3162 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3163 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3164 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3168 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3169 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3171 ne1
= build_logical_expr (INTRINSIC_NE
,
3172 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3173 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3174 ne2
= build_logical_expr (INTRINSIC_NE
,
3175 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3176 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3177 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3182 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3183 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3185 ne1
= build_logical_expr (INTRINSIC_NE
,
3186 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3187 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3188 ne2
= build_logical_expr (INTRINSIC_NE
,
3189 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3190 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3191 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3195 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3196 cond
= build_logical_expr (INTRINSIC_NE
,
3197 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3198 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3202 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3203 cond
= build_logical_expr (INTRINSIC_NE
,
3204 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3205 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3213 gfc_simplify_expr (cond
, 0);
3215 /* We need two identical allocate statements in two
3216 branches of the IF statement. */
3218 allocate1
= XCNEW (gfc_code
);
3219 allocate1
->op
= EXEC_ALLOCATE
;
3220 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3221 allocate1
->loc
= c
->where
;
3222 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3224 allocate_else
= XCNEW (gfc_code
);
3225 allocate_else
->op
= EXEC_ALLOCATE
;
3226 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3227 allocate_else
->loc
= c
->where
;
3228 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3230 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3231 "_gfortran_allocated", c
->where
,
3232 1, gfc_copy_expr (c
));
3234 deallocate
= XCNEW (gfc_code
);
3235 deallocate
->op
= EXEC_DEALLOCATE
;
3236 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3237 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3238 deallocate
->next
= allocate1
;
3239 deallocate
->loc
= c
->where
;
3241 if_size_2
= XCNEW (gfc_code
);
3242 if_size_2
->op
= EXEC_IF
;
3243 if_size_2
->expr1
= cond
;
3244 if_size_2
->loc
= c
->where
;
3245 if_size_2
->next
= deallocate
;
3247 if_size_1
= XCNEW (gfc_code
);
3248 if_size_1
->op
= EXEC_IF
;
3249 if_size_1
->block
= if_size_2
;
3250 if_size_1
->loc
= c
->where
;
3252 else_alloc
= XCNEW (gfc_code
);
3253 else_alloc
->op
= EXEC_IF
;
3254 else_alloc
->loc
= c
->where
;
3255 else_alloc
->next
= allocate_else
;
3257 if_alloc_2
= XCNEW (gfc_code
);
3258 if_alloc_2
->op
= EXEC_IF
;
3259 if_alloc_2
->expr1
= allocated
;
3260 if_alloc_2
->loc
= c
->where
;
3261 if_alloc_2
->next
= if_size_1
;
3262 if_alloc_2
->block
= else_alloc
;
3264 if_alloc_1
= XCNEW (gfc_code
);
3265 if_alloc_1
->op
= EXEC_IF
;
3266 if_alloc_1
->block
= if_alloc_2
;
3267 if_alloc_1
->loc
= c
->where
;
3272 /* Callback function for has_function_or_op. */
3275 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3276 void *data ATTRIBUTE_UNUSED
)
3281 return (*e
)->expr_type
== EXPR_FUNCTION
3282 || (*e
)->expr_type
== EXPR_OP
;
3285 /* Returns true if the expression contains a function. */
3288 has_function_or_op (gfc_expr
**e
)
3293 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3296 /* Freeze (assign to a temporary variable) a single expression. */
3299 freeze_expr (gfc_expr
**ep
)
3302 if (has_function_or_op (ep
))
3304 ne
= create_var (*ep
, "freeze");
3309 /* Go through an expression's references and assign them to temporary
3310 variables if they contain functions. This is usually done prior to
3311 front-end scalarization to avoid multiple invocations of functions. */
3314 freeze_references (gfc_expr
*e
)
3320 for (r
=e
->ref
; r
; r
=r
->next
)
3322 if (r
->type
== REF_SUBSTRING
)
3324 if (r
->u
.ss
.start
!= NULL
)
3325 freeze_expr (&r
->u
.ss
.start
);
3327 if (r
->u
.ss
.end
!= NULL
)
3328 freeze_expr (&r
->u
.ss
.end
);
3330 else if (r
->type
== REF_ARRAY
)
3339 for (i
=0; i
<ar
->dimen
; i
++)
3341 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3343 freeze_expr (&ar
->start
[i
]);
3344 freeze_expr (&ar
->end
[i
]);
3345 freeze_expr (&ar
->stride
[i
]);
3347 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3349 freeze_expr (&ar
->start
[i
]);
3355 for (i
=0; i
<ar
->dimen
; i
++)
3356 freeze_expr (&ar
->start
[i
]);
3366 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3369 convert_to_index_kind (gfc_expr
*e
)
3373 gcc_assert (e
!= NULL
);
3375 res
= gfc_copy_expr (e
);
3377 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3379 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3383 ts
.type
= BT_INTEGER
;
3384 ts
.kind
= gfc_index_integer_kind
;
3386 gfc_convert_type_warn (e
, &ts
, 2, 0);
3392 /* Function to create a DO loop including creation of the
3393 iteration variable. gfc_expr are copied.*/
3396 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3397 gfc_namespace
*ns
, char *vname
)
3400 char name
[GFC_MAX_SYMBOL_LEN
+1];
3401 gfc_symtree
*symtree
;
3406 /* Create an expression for the iteration variable. */
3408 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3410 sprintf (name
, "__var_%d_do", var_num
++);
3413 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3416 /* Create the loop variable. */
3418 symbol
= symtree
->n
.sym
;
3419 symbol
->ts
.type
= BT_INTEGER
;
3420 symbol
->ts
.kind
= gfc_index_integer_kind
;
3421 symbol
->attr
.flavor
= FL_VARIABLE
;
3422 symbol
->attr
.referenced
= 1;
3423 symbol
->attr
.dimension
= 0;
3424 symbol
->attr
.fe_temp
= 1;
3425 gfc_commit_symbol (symbol
);
3427 i
= gfc_get_expr ();
3428 i
->expr_type
= EXPR_VARIABLE
;
3432 i
->symtree
= symtree
;
3434 /* ... and the nested DO statements. */
3435 n
= XCNEW (gfc_code
);
3438 n
->ext
.iterator
= gfc_get_iterator ();
3439 n
->ext
.iterator
->var
= i
;
3440 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3441 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3443 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3445 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3448 n2
= XCNEW (gfc_code
);
3456 /* Get the upper bound of the DO loops for matmul along a dimension. This
3460 get_size_m1 (gfc_expr
*e
, int dimen
)
3465 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3467 res
= gfc_get_constant_expr (BT_INTEGER
,
3468 gfc_index_integer_kind
, &e
->where
);
3469 mpz_sub_ui (res
->value
.integer
, size
, 1);
3474 res
= get_operand (INTRINSIC_MINUS
,
3475 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3476 gfc_get_int_expr (gfc_index_integer_kind
,
3478 gfc_simplify_expr (res
, 0);
3484 /* Function to return a scalarized expression. It is assumed that indices are
3485 zero based to make generation of DO loops easier. A zero as index will
3486 access the first element along a dimension. Single element references will
3487 be skipped. A NULL as an expression will be replaced by a full reference.
3488 This assumes that the index loops have gfc_index_integer_kind, and that all
3489 references have been frozen. */
3492 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3501 e
= gfc_copy_expr(e_in
);
3505 ar
= gfc_find_array_ref (e
);
3507 /* We scalarize count_index variables, reducing the rank by count_index. */
3509 e
->rank
= rank
- count_index
;
3511 was_fullref
= ar
->type
== AR_FULL
;
3514 ar
->type
= AR_ELEMENT
;
3516 ar
->type
= AR_SECTION
;
3518 /* Loop over the indices. For each index, create the expression
3519 index * stride + lbound(e, dim). */
3522 for (i
=0; i
< ar
->dimen
; i
++)
3524 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3526 if (index
[i_index
] != NULL
)
3528 gfc_expr
*lbound
, *nindex
;
3531 loopvar
= gfc_copy_expr (index
[i_index
]);
3537 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3538 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3542 ts
.type
= BT_INTEGER
;
3543 ts
.kind
= gfc_index_integer_kind
;
3544 gfc_convert_type (tmp
, &ts
, 2);
3546 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3551 /* Calculate the lower bound of the expression. */
3554 lbound
= gfc_copy_expr (ar
->start
[i
]);
3555 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3559 ts
.type
= BT_INTEGER
;
3560 ts
.kind
= gfc_index_integer_kind
;
3561 gfc_convert_type (lbound
, &ts
, 2);
3570 lbound_e
= gfc_copy_expr (e_in
);
3572 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3573 if (ref
->type
== REF_ARRAY
3574 && (ref
->u
.ar
.type
== AR_FULL
3575 || ref
->u
.ar
.type
== AR_SECTION
))
3580 gfc_free_ref_list (ref
->next
);
3586 /* Look at full individual sections, like a(:). The first index
3587 is the lbound of a full ref. */
3594 /* For assumed size, we need to keep around the final
3595 reference in order not to get an error on resolution
3596 below, and we cannot use AR_FULL. */
3598 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3600 ar
->type
= AR_SECTION
;
3609 for (j
= 0; j
< to
; j
++)
3611 gfc_free_expr (ar
->start
[j
]);
3612 ar
->start
[j
] = NULL
;
3613 gfc_free_expr (ar
->end
[j
]);
3615 gfc_free_expr (ar
->stride
[j
]);
3616 ar
->stride
[j
] = NULL
;
3619 /* We have to get rid of the shape, if there is one. Do
3620 so by freeing it and calling gfc_resolve to rebuild
3621 it, if necessary. */
3623 if (lbound_e
->shape
)
3624 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3626 lbound_e
->rank
= ar
->dimen
;
3627 gfc_resolve_expr (lbound_e
);
3629 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3631 gfc_free_expr (lbound_e
);
3634 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3636 gfc_free_expr (ar
->start
[i
]);
3637 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3639 gfc_free_expr (ar
->end
[i
]);
3641 gfc_free_expr (ar
->stride
[i
]);
3642 ar
->stride
[i
] = NULL
;
3643 gfc_simplify_expr (ar
->start
[i
], 0);
3645 else if (was_fullref
)
3647 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3653 /* Bounds checking will be done before the loops if -fcheck=bounds
3655 e
->no_bounds_check
= 1;
3659 /* Helper function to check for a dimen vector as subscript. */
3662 has_dimen_vector_ref (gfc_expr
*e
)
3667 ar
= gfc_find_array_ref (e
);
3669 if (ar
->type
== AR_FULL
)
3672 for (i
=0; i
<ar
->dimen
; i
++)
3673 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3679 /* If handed an expression of the form
3683 check if A can be handled by matmul and return if there is an uneven number
3684 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3685 otherwise. The caller has to check for the correct rank. */
3688 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3695 if (e
->expr_type
== EXPR_VARIABLE
)
3697 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3700 else if (e
->expr_type
== EXPR_FUNCTION
)
3702 if (e
->value
.function
.isym
== NULL
)
3705 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3707 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3708 *transpose
= !*transpose
;
3714 e
= e
->value
.function
.actual
->expr
;
3721 /* Inline assignments of the form c = matmul(a,b).
3722 Handle only the cases currently where b and c are rank-two arrays.
3724 This basically translates the code to
3730 do k=0, size(a, 2)-1
3731 do i=0, size(a, 1)-1
3732 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3733 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3734 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3735 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3744 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3745 void *data ATTRIBUTE_UNUSED
)
3748 gfc_expr
*expr1
, *expr2
;
3749 gfc_expr
*matrix_a
, *matrix_b
;
3750 gfc_actual_arglist
*a
, *b
;
3751 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3753 gfc_expr
*u1
, *u2
, *u3
;
3755 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3757 gfc_expr
*var_1
, *var_2
, *var_3
;
3760 gfc_intrinsic_op op_times
, op_plus
;
3761 enum matrix_case m_case
;
3763 gfc_code
*if_limit
= NULL
;
3764 gfc_code
**next_code_point
;
3765 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3767 if (co
->op
!= EXEC_ASSIGN
)
3770 if (in_where
|| in_assoc_list
)
3773 /* The BLOCKS generated for the temporary variables and FORALL don't
3775 if (forall_level
> 0)
3778 /* For now don't do anything in OpenMP workshare, it confuses
3779 its translation, which expects only the allowed statements in there.
3780 We should figure out how to parallelize this eventually. */
3781 if (in_omp_workshare
)
3786 if (expr2
->expr_type
!= EXPR_FUNCTION
3787 || expr2
->value
.function
.isym
== NULL
3788 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3792 inserted_block
= NULL
;
3793 changed_statement
= NULL
;
3795 a
= expr2
->value
.function
.actual
;
3796 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3797 if (matrix_a
== NULL
)
3801 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3802 if (matrix_b
== NULL
)
3805 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3806 || has_dimen_vector_ref (matrix_b
))
3809 /* We do not handle data dependencies yet. */
3810 if (gfc_check_dependency (expr1
, matrix_a
, true)
3811 || gfc_check_dependency (expr1
, matrix_b
, true))
3815 if (matrix_a
->rank
== 2)
3819 if (matrix_b
->rank
== 2 && !transpose_b
)
3824 if (matrix_b
->rank
== 1)
3826 else /* matrix_b->rank == 2 */
3835 else /* matrix_a->rank == 1 */
3837 if (matrix_b
->rank
== 2)
3847 ns
= insert_block ();
3849 /* Assign the type of the zero expression for initializing the resulting
3850 array, and the expression (+ and * for real, integer and complex;
3851 .and. and .or for logical. */
3853 switch(expr1
->ts
.type
)
3856 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3857 op_times
= INTRINSIC_TIMES
;
3858 op_plus
= INTRINSIC_PLUS
;
3862 op_times
= INTRINSIC_AND
;
3863 op_plus
= INTRINSIC_OR
;
3864 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3868 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3870 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3871 op_times
= INTRINSIC_TIMES
;
3872 op_plus
= INTRINSIC_PLUS
;
3876 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3878 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3879 op_times
= INTRINSIC_TIMES
;
3880 op_plus
= INTRINSIC_PLUS
;
3888 current_code
= &ns
->code
;
3890 /* Freeze the references, keeping track of how many temporary variables were
3893 freeze_references (matrix_a
);
3894 freeze_references (matrix_b
);
3895 freeze_references (expr1
);
3898 next_code_point
= current_code
;
3901 next_code_point
= &ns
->code
;
3902 for (i
=0; i
<n_vars
; i
++)
3903 next_code_point
= &(*next_code_point
)->next
;
3906 /* Take care of the inline flag. If the limit check evaluates to a
3907 constant, dead code elimination will eliminate the unneeded branch. */
3909 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3911 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3913 /* Insert the original statement into the else branch. */
3914 if_limit
->block
->block
->next
= co
;
3917 /* ... and the new ones go into the original one. */
3918 *next_code_point
= if_limit
;
3919 next_code_point
= &if_limit
->block
->next
;
3922 zero_e
->no_bounds_check
= 1;
3924 assign_zero
= XCNEW (gfc_code
);
3925 assign_zero
->op
= EXEC_ASSIGN
;
3926 assign_zero
->loc
= co
->loc
;
3927 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3928 assign_zero
->expr1
->no_bounds_check
= 1;
3929 assign_zero
->expr2
= zero_e
;
3931 /* Handle the reallocation, if needed. */
3932 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3934 gfc_code
*lhs_alloc
;
3936 /* Only need to check a single dimension for the A2B2 case for
3937 bounds checking, the rest will be allocated. Also check this
3940 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3943 if (m_case
== A2B2
|| m_case
== A2B1
)
3947 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3948 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3949 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3950 "in MATMUL intrinsic: Is %ld, should be %ld");
3951 *next_code_point
= test
;
3952 next_code_point
= &test
->next
;
3954 else if (m_case
== A1B2
)
3958 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3959 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3960 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3961 "in MATMUL intrinsic: Is %ld, should be %ld");
3962 *next_code_point
= test
;
3963 next_code_point
= &test
->next
;
3967 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3969 *next_code_point
= lhs_alloc
;
3970 next_code_point
= &lhs_alloc
->next
;
3973 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3976 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3978 if (m_case
== A2B2
|| m_case
== A2B1
)
3980 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3981 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3982 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3983 "in MATMUL intrinsic: Is %ld, should be %ld");
3984 *next_code_point
= test
;
3985 next_code_point
= &test
->next
;
3987 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3988 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3991 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3992 "MATMUL intrinsic for dimension 1: "
3993 "is %ld, should be %ld");
3994 else if (m_case
== A2B1
)
3995 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3996 "MATMUL intrinsic: "
3997 "is %ld, should be %ld");
4000 *next_code_point
= test
;
4001 next_code_point
= &test
->next
;
4003 else if (m_case
== A1B2
)
4005 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4006 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4007 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
4008 "in MATMUL intrinsic: Is %ld, should be %ld");
4009 *next_code_point
= test
;
4010 next_code_point
= &test
->next
;
4012 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4013 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4015 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
4016 "MATMUL intrinsic: "
4017 "is %ld, should be %ld");
4019 *next_code_point
= test
;
4020 next_code_point
= &test
->next
;
4025 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4026 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4027 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4028 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
4030 *next_code_point
= test
;
4031 next_code_point
= &test
->next
;
4034 if (m_case
== A2B2T
)
4036 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4037 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4038 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
4039 "MATMUL intrinsic for dimension 1: "
4040 "is %ld, should be %ld");
4042 *next_code_point
= test
;
4043 next_code_point
= &test
->next
;
4045 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4046 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4047 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
4048 "MATMUL intrinsic for dimension 2: "
4049 "is %ld, should be %ld");
4050 *next_code_point
= test
;
4051 next_code_point
= &test
->next
;
4053 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4054 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4056 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
4057 "MATMUL intrnisic for dimension 2: "
4058 "is %ld, should be %ld");
4059 *next_code_point
= test
;
4060 next_code_point
= &test
->next
;
4064 if (m_case
== A2TB2
)
4066 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4067 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4069 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
4070 "MATMUL intrinsic for dimension 1: "
4071 "is %ld, should be %ld");
4073 *next_code_point
= test
;
4074 next_code_point
= &test
->next
;
4076 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4077 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4078 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4079 "MATMUL intrinsic for dimension 2: "
4080 "is %ld, should be %ld");
4081 *next_code_point
= test
;
4082 next_code_point
= &test
->next
;
4084 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4085 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4087 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
4088 "MATMUL intrnisic for dimension 2: "
4089 "is %ld, should be %ld");
4090 *next_code_point
= test
;
4091 next_code_point
= &test
->next
;
4096 *next_code_point
= assign_zero
;
4098 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4100 assign_matmul
= XCNEW (gfc_code
);
4101 assign_matmul
->op
= EXEC_ASSIGN
;
4102 assign_matmul
->loc
= co
->loc
;
4104 /* Get the bounds for the loops, create them and create the scalarized
4110 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4112 u1
= get_size_m1 (matrix_b
, 2);
4113 u2
= get_size_m1 (matrix_a
, 2);
4114 u3
= get_size_m1 (matrix_a
, 1);
4116 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4117 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4118 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4120 do_1
->block
->next
= do_2
;
4121 do_2
->block
->next
= do_3
;
4122 do_3
->block
->next
= assign_matmul
;
4124 var_1
= do_1
->ext
.iterator
->var
;
4125 var_2
= do_2
->ext
.iterator
->var
;
4126 var_3
= do_3
->ext
.iterator
->var
;
4130 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4134 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4138 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4143 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4145 u1
= get_size_m1 (matrix_b
, 1);
4146 u2
= get_size_m1 (matrix_a
, 2);
4147 u3
= get_size_m1 (matrix_a
, 1);
4149 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4150 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4151 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4153 do_1
->block
->next
= do_2
;
4154 do_2
->block
->next
= do_3
;
4155 do_3
->block
->next
= assign_matmul
;
4157 var_1
= do_1
->ext
.iterator
->var
;
4158 var_2
= do_2
->ext
.iterator
->var
;
4159 var_3
= do_3
->ext
.iterator
->var
;
4163 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4167 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4171 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4176 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4178 u1
= get_size_m1 (matrix_a
, 2);
4179 u2
= get_size_m1 (matrix_b
, 2);
4180 u3
= get_size_m1 (matrix_a
, 1);
4182 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4183 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4184 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4186 do_1
->block
->next
= do_2
;
4187 do_2
->block
->next
= do_3
;
4188 do_3
->block
->next
= assign_matmul
;
4190 var_1
= do_1
->ext
.iterator
->var
;
4191 var_2
= do_2
->ext
.iterator
->var
;
4192 var_3
= do_3
->ext
.iterator
->var
;
4196 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4200 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4204 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4209 u1
= get_size_m1 (matrix_b
, 1);
4210 u2
= get_size_m1 (matrix_a
, 1);
4212 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4213 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4215 do_1
->block
->next
= do_2
;
4216 do_2
->block
->next
= assign_matmul
;
4218 var_1
= do_1
->ext
.iterator
->var
;
4219 var_2
= do_2
->ext
.iterator
->var
;
4222 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4226 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4229 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4234 u1
= get_size_m1 (matrix_b
, 2);
4235 u2
= get_size_m1 (matrix_a
, 1);
4237 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4238 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4240 do_1
->block
->next
= do_2
;
4241 do_2
->block
->next
= assign_matmul
;
4243 var_1
= do_1
->ext
.iterator
->var
;
4244 var_2
= do_2
->ext
.iterator
->var
;
4247 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4250 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4254 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4262 /* Build the conjg call around the variables. Set the typespec manually
4263 because gfc_build_intrinsic_call sometimes gets this wrong. */
4268 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4269 matrix_a
->where
, 1, ascalar
);
4277 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4278 matrix_b
->where
, 1, bscalar
);
4281 /* First loop comes after the zero assignment. */
4282 assign_zero
->next
= do_1
;
4284 /* Build the assignment expression in the loop. */
4285 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4287 mult
= get_operand (op_times
, ascalar
, bscalar
);
4288 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4290 /* If we don't want to keep the original statement around in
4291 the else branch, we can free it. */
4293 if (if_limit
== NULL
)
4294 gfc_free_statements(co
);
4298 gfc_free_expr (zero
);
4304 /* Code for index interchange for loops which are grouped together in DO
4305 CONCURRENT or FORALL statements. This is currently only applied if the
4306 iterations are grouped together in a single statement.
4308 For this transformation, it is assumed that memory access in strides is
4309 expensive, and that loops which access later indices (which access memory
4310 in bigger strides) should be moved to the first loops.
4312 For this, a loop over all the statements is executed, counting the times
4313 that the loop iteration values are accessed in each index. The loop
4314 indices are then sorted to minimize access to later indices from inner
4317 /* Type for holding index information. */
4321 gfc_forall_iterator
*fa
;
4323 int n
[GFC_MAX_DIMENSIONS
];
4326 /* Callback function to determine if an expression is the
4327 corresponding variable. */
4330 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4332 gfc_expr
*expr
= *e
;
4335 if (expr
->expr_type
!= EXPR_VARIABLE
)
4338 sym
= (gfc_symbol
*) data
;
4339 return sym
== expr
->symtree
->n
.sym
;
4342 /* Callback function to calculate the cost of a certain index. */
4345 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4355 if (expr
->expr_type
!= EXPR_VARIABLE
)
4359 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4361 if (ref
->type
== REF_ARRAY
)
4367 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4370 ind
= (ind_type
*) data
;
4371 for (i
= 0; i
< ar
->dimen
; i
++)
4373 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4375 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4382 /* Callback function for qsort, to sort the loop indices. */
4385 loop_comp (const void *e1
, const void *e2
)
4387 const ind_type
*i1
= (const ind_type
*) e1
;
4388 const ind_type
*i2
= (const ind_type
*) e2
;
4391 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4393 if (i1
->n
[i
] != i2
->n
[i
])
4394 return i1
->n
[i
] - i2
->n
[i
];
4396 /* All other things being equal, let's not change the ordering. */
4397 return i2
->num
- i1
->num
;
4400 /* Main function to do the index interchange. */
4403 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4404 void *data ATTRIBUTE_UNUSED
)
4409 gfc_forall_iterator
*fa
;
4413 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4417 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4420 /* Nothing to reorder. */
4424 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4427 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4429 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4431 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4436 ind
[n_iter
].sym
= NULL
;
4437 ind
[n_iter
].fa
= NULL
;
4439 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4440 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4442 /* Do the actual index interchange. */
4443 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4444 for (i
=1; i
<n_iter
; i
++)
4446 fa
->next
= ind
[i
].fa
;
4451 if (flag_warn_frontend_loop_interchange
)
4453 for (i
=1; i
<n_iter
; i
++)
4455 if (ind
[i
-1].num
> ind
[i
].num
)
4457 gfc_warning (OPT_Wfrontend_loop_interchange
,
4458 "Interchanging loops at %L", &co
->loc
);
4467 #define WALK_SUBEXPR(NODE) \
4470 result = gfc_expr_walker (&(NODE), exprfn, data); \
4475 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4477 /* Walk expression *E, calling EXPRFN on each expression in it. */
4480 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4484 int walk_subtrees
= 1;
4485 gfc_actual_arglist
*a
;
4489 int result
= exprfn (e
, &walk_subtrees
, data
);
4493 switch ((*e
)->expr_type
)
4496 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4497 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4500 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4501 WALK_SUBEXPR (a
->expr
);
4505 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4506 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4507 WALK_SUBEXPR (a
->expr
);
4510 case EXPR_STRUCTURE
:
4512 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4513 c
= gfc_constructor_next (c
))
4515 if (c
->iterator
== NULL
)
4516 WALK_SUBEXPR (c
->expr
);
4520 WALK_SUBEXPR (c
->expr
);
4522 WALK_SUBEXPR (c
->iterator
->var
);
4523 WALK_SUBEXPR (c
->iterator
->start
);
4524 WALK_SUBEXPR (c
->iterator
->end
);
4525 WALK_SUBEXPR (c
->iterator
->step
);
4529 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4532 /* Fall through to the variable case in order to walk the
4536 case EXPR_SUBSTRING
:
4538 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4547 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4549 for (i
=0; i
< ar
->dimen
; i
++)
4551 WALK_SUBEXPR (ar
->start
[i
]);
4552 WALK_SUBEXPR (ar
->end
[i
]);
4553 WALK_SUBEXPR (ar
->stride
[i
]);
4560 WALK_SUBEXPR (r
->u
.ss
.start
);
4561 WALK_SUBEXPR (r
->u
.ss
.end
);
4577 #define WALK_SUBCODE(NODE) \
4580 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4586 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4587 on each expression in it. If any of the hooks returns non-zero, that
4588 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4589 no subcodes or subexpressions are traversed. */
4592 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4595 for (; *c
; c
= &(*c
)->next
)
4597 int walk_subtrees
= 1;
4598 int result
= codefn (c
, &walk_subtrees
, data
);
4605 gfc_actual_arglist
*a
;
4607 gfc_association_list
*alist
;
4608 bool saved_in_omp_workshare
;
4609 bool saved_in_where
;
4611 /* There might be statement insertions before the current code,
4612 which must not affect the expression walker. */
4615 saved_in_omp_workshare
= in_omp_workshare
;
4616 saved_in_where
= in_where
;
4622 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4623 if (co
->ext
.block
.assoc
)
4625 bool saved_in_assoc_list
= in_assoc_list
;
4627 in_assoc_list
= true;
4628 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4629 WALK_SUBEXPR (alist
->target
);
4631 in_assoc_list
= saved_in_assoc_list
;
4638 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4639 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4640 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4641 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4653 case EXEC_ASSIGN_CALL
:
4654 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4655 WALK_SUBEXPR (a
->expr
);
4659 WALK_SUBEXPR (co
->expr1
);
4660 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4661 WALK_SUBEXPR (a
->expr
);
4665 WALK_SUBEXPR (co
->expr1
);
4667 for (b
= co
->block
; b
; b
= b
->block
)
4670 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4672 WALK_SUBEXPR (cp
->low
);
4673 WALK_SUBEXPR (cp
->high
);
4675 WALK_SUBCODE (b
->next
);
4680 case EXEC_DEALLOCATE
:
4683 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4684 WALK_SUBEXPR (a
->expr
);
4689 case EXEC_DO_CONCURRENT
:
4691 gfc_forall_iterator
*fa
;
4692 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4694 WALK_SUBEXPR (fa
->var
);
4695 WALK_SUBEXPR (fa
->start
);
4696 WALK_SUBEXPR (fa
->end
);
4697 WALK_SUBEXPR (fa
->stride
);
4699 if (co
->op
== EXEC_FORALL
)
4705 WALK_SUBEXPR (co
->ext
.open
->unit
);
4706 WALK_SUBEXPR (co
->ext
.open
->file
);
4707 WALK_SUBEXPR (co
->ext
.open
->status
);
4708 WALK_SUBEXPR (co
->ext
.open
->access
);
4709 WALK_SUBEXPR (co
->ext
.open
->form
);
4710 WALK_SUBEXPR (co
->ext
.open
->recl
);
4711 WALK_SUBEXPR (co
->ext
.open
->blank
);
4712 WALK_SUBEXPR (co
->ext
.open
->position
);
4713 WALK_SUBEXPR (co
->ext
.open
->action
);
4714 WALK_SUBEXPR (co
->ext
.open
->delim
);
4715 WALK_SUBEXPR (co
->ext
.open
->pad
);
4716 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4717 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4718 WALK_SUBEXPR (co
->ext
.open
->convert
);
4719 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4720 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4721 WALK_SUBEXPR (co
->ext
.open
->round
);
4722 WALK_SUBEXPR (co
->ext
.open
->sign
);
4723 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4724 WALK_SUBEXPR (co
->ext
.open
->id
);
4725 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4726 WALK_SUBEXPR (co
->ext
.open
->share
);
4727 WALK_SUBEXPR (co
->ext
.open
->cc
);
4731 WALK_SUBEXPR (co
->ext
.close
->unit
);
4732 WALK_SUBEXPR (co
->ext
.close
->status
);
4733 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4734 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4737 case EXEC_BACKSPACE
:
4741 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4742 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4743 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4747 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4748 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4749 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4750 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4751 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4752 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4753 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4754 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4755 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4756 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4757 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4758 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4759 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4760 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4761 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4762 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4763 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4764 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4765 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4766 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4767 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4768 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4769 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4770 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4771 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4772 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4773 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4774 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4775 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4776 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4777 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4778 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4779 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4780 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4781 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4782 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4786 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4787 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4788 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4789 WALK_SUBEXPR (co
->ext
.wait
->id
);
4794 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4795 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4796 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4797 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4798 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4799 WALK_SUBEXPR (co
->ext
.dt
->size
);
4800 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4801 WALK_SUBEXPR (co
->ext
.dt
->id
);
4802 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4803 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4804 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4805 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4806 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4807 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4808 WALK_SUBEXPR (co
->ext
.dt
->round
);
4809 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4810 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4813 case EXEC_OMP_PARALLEL
:
4814 case EXEC_OMP_PARALLEL_DO
:
4815 case EXEC_OMP_PARALLEL_DO_SIMD
:
4816 case EXEC_OMP_PARALLEL_SECTIONS
:
4818 in_omp_workshare
= false;
4820 /* This goto serves as a shortcut to avoid code
4821 duplication or a larger if or switch statement. */
4822 goto check_omp_clauses
;
4824 case EXEC_OMP_WORKSHARE
:
4825 case EXEC_OMP_PARALLEL_WORKSHARE
:
4827 in_omp_workshare
= true;
4831 case EXEC_OMP_CRITICAL
:
4832 case EXEC_OMP_DISTRIBUTE
:
4833 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4834 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4835 case EXEC_OMP_DISTRIBUTE_SIMD
:
4837 case EXEC_OMP_DO_SIMD
:
4838 case EXEC_OMP_ORDERED
:
4839 case EXEC_OMP_SECTIONS
:
4840 case EXEC_OMP_SINGLE
:
4841 case EXEC_OMP_END_SINGLE
:
4843 case EXEC_OMP_TASKLOOP
:
4844 case EXEC_OMP_TASKLOOP_SIMD
:
4845 case EXEC_OMP_TARGET
:
4846 case EXEC_OMP_TARGET_DATA
:
4847 case EXEC_OMP_TARGET_ENTER_DATA
:
4848 case EXEC_OMP_TARGET_EXIT_DATA
:
4849 case EXEC_OMP_TARGET_PARALLEL
:
4850 case EXEC_OMP_TARGET_PARALLEL_DO
:
4851 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4852 case EXEC_OMP_TARGET_SIMD
:
4853 case EXEC_OMP_TARGET_TEAMS
:
4854 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4855 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4856 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4857 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4858 case EXEC_OMP_TARGET_UPDATE
:
4860 case EXEC_OMP_TEAMS
:
4861 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4862 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4863 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4864 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4866 /* Come to this label only from the
4867 EXEC_OMP_PARALLEL_* cases above. */
4871 if (co
->ext
.omp_clauses
)
4873 gfc_omp_namelist
*n
;
4874 static int list_types
[]
4875 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4876 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4878 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4879 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4880 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4881 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4882 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4883 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4884 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4885 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4886 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4887 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4888 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4889 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4890 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4891 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4892 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4893 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4895 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4897 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4899 WALK_SUBEXPR (n
->expr
);
4906 WALK_SUBEXPR (co
->expr1
);
4907 WALK_SUBEXPR (co
->expr2
);
4908 WALK_SUBEXPR (co
->expr3
);
4909 WALK_SUBEXPR (co
->expr4
);
4910 for (b
= co
->block
; b
; b
= b
->block
)
4912 WALK_SUBEXPR (b
->expr1
);
4913 WALK_SUBEXPR (b
->expr2
);
4914 WALK_SUBCODE (b
->next
);
4917 if (co
->op
== EXEC_FORALL
)
4920 if (co
->op
== EXEC_DO
)
4923 if (co
->op
== EXEC_IF
)
4926 if (co
->op
== EXEC_SELECT
)
4929 in_omp_workshare
= saved_in_omp_workshare
;
4930 in_where
= saved_in_where
;