1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2017 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static bool has_dimen_vector_ref (gfc_expr
*);
57 static int matmul_temp_args (gfc_code
**, int *,void *data
);
58 static int index_interchange (gfc_code
**, int*, void *);
61 static void check_locus (gfc_namespace
*);
64 /* How deep we are inside an argument list. */
66 static int count_arglist
;
68 /* Vector of gfc_expr ** we operate on. */
70 static vec
<gfc_expr
**> expr_array
;
72 /* Pointer to the gfc_code we currently work on - to be able to insert
73 a block before the statement. */
75 static gfc_code
**current_code
;
77 /* Pointer to the block to be inserted, and the statement we are
78 changing within the block. */
80 static gfc_code
*inserted_block
, **changed_statement
;
82 /* The namespace we are currently dealing with. */
84 static gfc_namespace
*current_ns
;
86 /* If we are within any forall loop. */
88 static int forall_level
;
90 /* Keep track of whether we are within an OMP workshare. */
92 static bool in_omp_workshare
;
94 /* Keep track of whether we are within a WHERE statement. */
98 /* Keep track of iterators for array constructors. */
100 static int iterator_level
;
102 /* Keep track of DO loop levels. */
110 static vec
<do_t
> doloop_list
;
111 static int doloop_level
;
113 /* Keep track of if and select case levels. */
116 static int select_level
;
118 /* Vector of gfc_expr * to keep track of DO loops. */
120 struct my_struct
*evec
;
122 /* Keep track of association lists. */
124 static bool in_assoc_list
;
126 /* Counter for temporary variables. */
128 static int var_num
= 1;
130 /* What sort of matrix we are dealing with when inlining MATMUL. */
132 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
134 /* Keep track of the number of expressions we have inserted so far
139 /* Entry point - run all passes for a namespace. */
142 gfc_run_passes (gfc_namespace
*ns
)
145 /* Warn about dubious DO loops where the index might
152 doloop_list
.release ();
159 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
160 optimize_namespace (ns
);
162 if (flag_frontend_optimize
)
164 optimize_reduction (ns
);
165 if (flag_dump_fortran_optimized
)
166 gfc_dump_parse_tree (ns
, stdout
);
168 expr_array
.release ();
171 gfc_get_errors (&w
, &e
);
175 if (flag_realloc_lhs
)
176 realloc_strings (ns
);
181 /* Callback function: Warn if there is no location information in a
185 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
186 void *data ATTRIBUTE_UNUSED
)
189 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
190 gfc_warning_internal (0, "No location in statement");
196 /* Callback function: Warn if there is no location information in an
200 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
201 void *data ATTRIBUTE_UNUSED
)
204 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
205 gfc_warning_internal (0, "No location in expression near %L",
206 &((*current_code
)->loc
));
210 /* Run check for missing location information. */
213 check_locus (gfc_namespace
*ns
)
215 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
217 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
219 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
226 /* Callback for each gfc_code node invoked from check_realloc_strings.
227 For an allocatable LHS string which also appears as a variable on
239 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
240 void *data ATTRIBUTE_UNUSED
)
242 gfc_expr
*expr1
, *expr2
;
248 if (co
->op
!= EXEC_ASSIGN
)
252 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
253 || !gfc_expr_attr(expr1
).allocatable
254 || !expr1
->ts
.deferred
)
257 expr2
= gfc_discard_nops (co
->expr2
);
259 if (expr2
->expr_type
== EXPR_VARIABLE
)
261 found_substr
= false;
262 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
264 if (ref
->type
== REF_SUBSTRING
)
273 else if (expr2
->expr_type
!= EXPR_OP
274 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
)
277 if (!gfc_check_dependency (expr1
, expr2
, true))
280 /* gfc_check_dependency doesn't always pick up identical expressions.
281 However, eliminating the above sends the compiler into an infinite
282 loop on valid expressions. Without this check, the gimplifier emits
283 an ICE for a = a, where a is deferred character length. */
284 if (!gfc_dep_compare_expr (expr1
, expr2
))
288 inserted_block
= NULL
;
289 changed_statement
= NULL
;
290 n
= create_var (expr2
, "realloc_string");
295 /* Callback for each gfc_code node invoked through gfc_code_walker
296 from optimize_namespace. */
299 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
300 void *data ATTRIBUTE_UNUSED
)
307 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
308 || op
== EXEC_CALL_PPC
)
314 inserted_block
= NULL
;
315 changed_statement
= NULL
;
317 if (op
== EXEC_ASSIGN
)
318 optimize_assignment (*c
);
322 /* Callback for each gfc_expr node invoked through gfc_code_walker
323 from optimize_namespace. */
326 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
327 void *data ATTRIBUTE_UNUSED
)
331 if ((*e
)->expr_type
== EXPR_FUNCTION
)
334 function_expr
= true;
337 function_expr
= false;
339 if (optimize_trim (*e
))
340 gfc_simplify_expr (*e
, 0);
342 if (optimize_lexical_comparison (*e
))
343 gfc_simplify_expr (*e
, 0);
345 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
346 gfc_simplify_expr (*e
, 0);
348 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
349 switch ((*e
)->value
.function
.isym
->id
)
351 case GFC_ISYM_MINLOC
:
352 case GFC_ISYM_MAXLOC
:
353 optimize_minmaxloc (e
);
365 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
366 function is a scalar, just copy it; otherwise returns the new element, the
367 old one can be freed. */
370 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
372 gfc_expr
*fcn
, *e
= c
->expr
;
374 fcn
= gfc_copy_expr (e
);
377 gfc_constructor_base newbase
;
379 gfc_constructor
*new_c
;
382 new_expr
= gfc_get_expr ();
383 new_expr
->expr_type
= EXPR_ARRAY
;
384 new_expr
->ts
= e
->ts
;
385 new_expr
->where
= e
->where
;
387 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
388 new_c
->iterator
= c
->iterator
;
389 new_expr
->value
.constructor
= newbase
;
397 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
399 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
400 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
401 fn
->value
.function
.isym
->name
,
402 fn
->where
, 3, fcn
, NULL
, NULL
);
403 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
404 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
405 fn
->value
.function
.isym
->name
,
406 fn
->where
, 2, fcn
, NULL
);
408 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
410 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
416 /* Callback function for optimzation of reductions to scalars. Transform ANY
417 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
418 correspondingly. Handly only the simple cases without MASK and DIM. */
421 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
422 void *data ATTRIBUTE_UNUSED
)
427 gfc_actual_arglist
*a
;
428 gfc_actual_arglist
*dim
;
430 gfc_expr
*res
, *new_expr
;
431 gfc_actual_arglist
*mask
;
435 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
436 || fn
->value
.function
.isym
== NULL
)
439 id
= fn
->value
.function
.isym
->id
;
441 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
442 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
445 a
= fn
->value
.function
.actual
;
447 /* Don't handle MASK or DIM. */
451 if (dim
->expr
!= NULL
)
454 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
457 if ( mask
->expr
!= NULL
)
463 if (arg
->expr_type
!= EXPR_ARRAY
)
472 case GFC_ISYM_PRODUCT
:
473 op
= INTRINSIC_TIMES
;
488 c
= gfc_constructor_first (arg
->value
.constructor
);
490 /* Don't do any simplififcation if we have
491 - no element in the constructor or
492 - only have a single element in the array which contains an
498 res
= copy_walk_reduction_arg (c
, fn
);
500 c
= gfc_constructor_next (c
);
503 new_expr
= gfc_get_expr ();
504 new_expr
->ts
= fn
->ts
;
505 new_expr
->expr_type
= EXPR_OP
;
506 new_expr
->rank
= fn
->rank
;
507 new_expr
->where
= fn
->where
;
508 new_expr
->value
.op
.op
= op
;
509 new_expr
->value
.op
.op1
= res
;
510 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
512 c
= gfc_constructor_next (c
);
515 gfc_simplify_expr (res
, 0);
522 /* Callback function for common function elimination, called from cfe_expr_0.
523 Put all eligible function expressions into expr_array. */
526 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
527 void *data ATTRIBUTE_UNUSED
)
530 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
533 /* We don't do character functions with unknown charlens. */
534 if ((*e
)->ts
.type
== BT_CHARACTER
535 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
536 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
539 /* We don't do function elimination within FORALL statements, it can
540 lead to wrong-code in certain circumstances. */
542 if (forall_level
> 0)
545 /* Function elimination inside an iterator could lead to functions which
546 depend on iterator variables being moved outside. FIXME: We should check
547 if the functions do indeed depend on the iterator variable. */
549 if (iterator_level
> 0)
552 /* If we don't know the shape at compile time, we create an allocatable
553 temporary variable to hold the intermediate result, but only if
554 allocation on assignment is active. */
556 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
559 /* Skip the test for pure functions if -faggressive-function-elimination
561 if ((*e
)->value
.function
.esym
)
563 /* Don't create an array temporary for elemental functions. */
564 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
567 /* Only eliminate potentially impure functions if the
568 user specifically requested it. */
569 if (!flag_aggressive_function_elimination
570 && !(*e
)->value
.function
.esym
->attr
.pure
571 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
575 if ((*e
)->value
.function
.isym
)
577 /* Conversions are handled on the fly by the middle end,
578 transpose during trans-* stages and TRANSFER by the middle end. */
579 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
580 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
581 || gfc_inline_intrinsic_function_p (*e
))
584 /* Don't create an array temporary for elemental functions,
585 as this would be wasteful of memory.
586 FIXME: Create a scalar temporary during scalarization. */
587 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
590 if (!(*e
)->value
.function
.isym
->pure
)
594 expr_array
.safe_push (e
);
598 /* Auxiliary function to check if an expression is a temporary created by
602 is_fe_temp (gfc_expr
*e
)
604 if (e
->expr_type
!= EXPR_VARIABLE
)
607 return e
->symtree
->n
.sym
->attr
.fe_temp
;
610 /* Determine the length of a string, if it can be evaluated as a constant
611 expression. Return a newly allocated gfc_expr or NULL on failure.
612 If the user specified a substring which is potentially longer than
613 the string itself, the string will be padded with spaces, which
617 constant_string_length (gfc_expr
*e
)
627 length
= e
->ts
.u
.cl
->length
;
628 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
629 return gfc_copy_expr(length
);
632 /* Return length of substring, if constant. */
633 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
635 if (ref
->type
== REF_SUBSTRING
636 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
638 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
641 mpz_add_ui (res
->value
.integer
, value
, 1);
647 /* Return length of char symbol, if constant. */
649 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
650 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
651 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
652 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
658 /* Insert a block at the current position unless it has already
659 been inserted; in this case use the one already there. */
661 static gfc_namespace
*
666 /* If the block hasn't already been created, do so. */
667 if (inserted_block
== NULL
)
669 inserted_block
= XCNEW (gfc_code
);
670 inserted_block
->op
= EXEC_BLOCK
;
671 inserted_block
->loc
= (*current_code
)->loc
;
672 ns
= gfc_build_block_ns (current_ns
);
673 inserted_block
->ext
.block
.ns
= ns
;
674 inserted_block
->ext
.block
.assoc
= NULL
;
676 ns
->code
= *current_code
;
678 /* If the statement has a label, make sure it is transferred to
679 the newly created block. */
681 if ((*current_code
)->here
)
683 inserted_block
->here
= (*current_code
)->here
;
684 (*current_code
)->here
= NULL
;
687 inserted_block
->next
= (*current_code
)->next
;
688 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
689 (*current_code
)->next
= NULL
;
690 /* Insert the BLOCK at the right position. */
691 *current_code
= inserted_block
;
692 ns
->parent
= current_ns
;
695 ns
= inserted_block
->ext
.block
.ns
;
700 /* Returns a new expression (a variable) to be used in place of the old one,
701 with an optional assignment statement before the current statement to set
702 the value of the variable. Creates a new BLOCK for the statement if that
703 hasn't already been done and puts the statement, plus the newly created
704 variables, in that block. Special cases: If the expression is constant or
705 a temporary which has already been created, just copy it. */
708 create_var (gfc_expr
* e
, const char *vname
)
710 char name
[GFC_MAX_SYMBOL_LEN
+1];
711 gfc_symtree
*symtree
;
719 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
720 return gfc_copy_expr (e
);
722 ns
= insert_block ();
725 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
727 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
729 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
732 symbol
= symtree
->n
.sym
;
737 symbol
->as
= gfc_get_array_spec ();
738 symbol
->as
->rank
= e
->rank
;
740 if (e
->shape
== NULL
)
742 /* We don't know the shape at compile time, so we use an
744 symbol
->as
->type
= AS_DEFERRED
;
745 symbol
->attr
.allocatable
= 1;
749 symbol
->as
->type
= AS_EXPLICIT
;
750 /* Copy the shape. */
751 for (i
=0; i
<e
->rank
; i
++)
755 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
757 mpz_set_si (p
->value
.integer
, 1);
758 symbol
->as
->lower
[i
] = p
;
760 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
762 mpz_set (q
->value
.integer
, e
->shape
[i
]);
763 symbol
->as
->upper
[i
] = q
;
769 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
773 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
774 length
= constant_string_length (e
);
776 symbol
->ts
.u
.cl
->length
= length
;
779 symbol
->attr
.allocatable
= 1;
784 symbol
->attr
.flavor
= FL_VARIABLE
;
785 symbol
->attr
.referenced
= 1;
786 symbol
->attr
.dimension
= e
->rank
> 0;
787 symbol
->attr
.fe_temp
= 1;
788 gfc_commit_symbol (symbol
);
790 result
= gfc_get_expr ();
791 result
->expr_type
= EXPR_VARIABLE
;
793 result
->ts
.deferred
= deferred
;
794 result
->rank
= e
->rank
;
795 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
796 result
->symtree
= symtree
;
797 result
->where
= e
->where
;
800 result
->ref
= gfc_get_ref ();
801 result
->ref
->type
= REF_ARRAY
;
802 result
->ref
->u
.ar
.type
= AR_FULL
;
803 result
->ref
->u
.ar
.where
= e
->where
;
804 result
->ref
->u
.ar
.dimen
= e
->rank
;
805 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
806 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
807 if (warn_array_temporaries
)
808 gfc_warning (OPT_Warray_temporaries
,
809 "Creating array temporary at %L", &(e
->where
));
812 /* Generate the new assignment. */
813 n
= XCNEW (gfc_code
);
815 n
->loc
= (*current_code
)->loc
;
816 n
->next
= *changed_statement
;
817 n
->expr1
= gfc_copy_expr (result
);
819 *changed_statement
= n
;
825 /* Warn about function elimination. */
828 do_warn_function_elimination (gfc_expr
*e
)
830 if (e
->expr_type
!= EXPR_FUNCTION
)
832 if (e
->value
.function
.esym
)
833 gfc_warning (OPT_Wfunction_elimination
,
834 "Removing call to function %qs at %L",
835 e
->value
.function
.esym
->name
, &(e
->where
));
836 else if (e
->value
.function
.isym
)
837 gfc_warning (OPT_Wfunction_elimination
,
838 "Removing call to function %qs at %L",
839 e
->value
.function
.isym
->name
, &(e
->where
));
841 /* Callback function for the code walker for doing common function
842 elimination. This builds up the list of functions in the expression
843 and goes through them to detect duplicates, which it then replaces
847 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
848 void *data ATTRIBUTE_UNUSED
)
854 /* Don't do this optimization within OMP workshare or ASSOC lists. */
856 if (in_omp_workshare
|| in_assoc_list
)
862 expr_array
.release ();
864 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
866 /* Walk through all the functions. */
868 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
870 /* Skip if the function has been replaced by a variable already. */
871 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
878 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
881 newvar
= create_var (*ei
, "fcn");
883 if (warn_function_elimination
)
884 do_warn_function_elimination (*ej
);
887 *ej
= gfc_copy_expr (newvar
);
894 /* We did all the necessary walking in this function. */
899 /* Callback function for common function elimination, called from
900 gfc_code_walker. This keeps track of the current code, in order
901 to insert statements as needed. */
904 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
907 inserted_block
= NULL
;
908 changed_statement
= NULL
;
910 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
911 and allocation on assigment are prohibited inside WHERE, and finally
912 masking an expression would lead to wrong-code when replacing
915 b = sum(foo(a) + foo(a))
926 if ((*c
)->op
== EXEC_WHERE
)
936 /* Dummy function for expression call back, for use when we
937 really don't want to do any walking. */
940 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
941 void *data ATTRIBUTE_UNUSED
)
947 /* Dummy function for code callback, for use when we really
948 don't want to do anything. */
950 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
951 int *walk_subtrees ATTRIBUTE_UNUSED
,
952 void *data ATTRIBUTE_UNUSED
)
957 /* Code callback function for converting
964 This is because common function elimination would otherwise place the
965 temporary variables outside the loop. */
968 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
969 void *data ATTRIBUTE_UNUSED
)
972 gfc_code
*c_if1
, *c_if2
, *c_exit
;
974 gfc_expr
*e_not
, *e_cond
;
976 if (co
->op
!= EXEC_DO_WHILE
)
979 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
984 /* Generate the condition of the if statement, which is .not. the original
986 e_not
= gfc_get_expr ();
987 e_not
->ts
= e_cond
->ts
;
988 e_not
->where
= e_cond
->where
;
989 e_not
->expr_type
= EXPR_OP
;
990 e_not
->value
.op
.op
= INTRINSIC_NOT
;
991 e_not
->value
.op
.op1
= e_cond
;
993 /* Generate the EXIT statement. */
994 c_exit
= XCNEW (gfc_code
);
995 c_exit
->op
= EXEC_EXIT
;
996 c_exit
->ext
.which_construct
= co
;
997 c_exit
->loc
= co
->loc
;
999 /* Generate the IF statement. */
1000 c_if2
= XCNEW (gfc_code
);
1001 c_if2
->op
= EXEC_IF
;
1002 c_if2
->expr1
= e_not
;
1003 c_if2
->next
= c_exit
;
1004 c_if2
->loc
= co
->loc
;
1006 /* ... plus the one to chain it to. */
1007 c_if1
= XCNEW (gfc_code
);
1008 c_if1
->op
= EXEC_IF
;
1009 c_if1
->block
= c_if2
;
1010 c_if1
->loc
= co
->loc
;
1012 /* Make the DO WHILE loop into a DO block by replacing the condition
1013 with a true constant. */
1014 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1016 /* Hang the generated if statement into the loop body. */
1018 loopblock
= co
->block
->next
;
1019 co
->block
->next
= c_if1
;
1020 c_if1
->next
= loopblock
;
1025 /* Code callback function for converting
1038 because otherwise common function elimination would place the BLOCKs
1039 into the wrong place. */
1042 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1043 void *data ATTRIBUTE_UNUSED
)
1046 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1048 if (co
->op
!= EXEC_IF
)
1051 /* This loop starts out with the first ELSE statement. */
1052 else_stmt
= co
->block
->block
;
1054 while (else_stmt
!= NULL
)
1056 gfc_code
*next_else
;
1058 /* If there is no condition, we're done. */
1059 if (else_stmt
->expr1
== NULL
)
1062 next_else
= else_stmt
->block
;
1064 /* Generate the new IF statement. */
1065 c_if2
= XCNEW (gfc_code
);
1066 c_if2
->op
= EXEC_IF
;
1067 c_if2
->expr1
= else_stmt
->expr1
;
1068 c_if2
->next
= else_stmt
->next
;
1069 c_if2
->loc
= else_stmt
->loc
;
1070 c_if2
->block
= next_else
;
1072 /* ... plus the one to chain it to. */
1073 c_if1
= XCNEW (gfc_code
);
1074 c_if1
->op
= EXEC_IF
;
1075 c_if1
->block
= c_if2
;
1076 c_if1
->loc
= else_stmt
->loc
;
1078 /* Insert the new IF after the ELSE. */
1079 else_stmt
->expr1
= NULL
;
1080 else_stmt
->next
= c_if1
;
1081 else_stmt
->block
= NULL
;
1083 else_stmt
= next_else
;
1085 /* Don't walk subtrees. */
1091 struct do_stack
*prev
;
1096 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1097 optimize by replacing do loops with their analog array slices. For
1100 write (*,*) (a(i), i=1,4)
1104 write (*,*) a(1:4:1) . */
1107 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1110 gfc_expr
*new_e
, *expr
, *start
;
1112 struct do_stack ds_push
;
1113 int i
, future_rank
= 0;
1114 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1117 /* Find the first transfer/do statement. */
1118 for (curr
= code
; curr
; curr
= curr
->next
)
1120 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1124 /* Ensure it is the only transfer/do statement because cases like
1126 write (*,*) (a(i), b(i), i=1,4)
1128 cannot be optimized. */
1130 if (!curr
|| curr
->next
)
1133 if (curr
->op
== EXEC_DO
)
1135 if (curr
->ext
.iterator
->var
->ref
)
1137 ds_push
.prev
= stack_top
;
1138 ds_push
.iter
= curr
->ext
.iterator
;
1139 ds_push
.code
= curr
;
1140 stack_top
= &ds_push
;
1141 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1143 if (curr
!= stack_top
->code
&& !*has_reached
)
1145 curr
->block
->next
= NULL
;
1146 gfc_free_statements (curr
);
1149 *has_reached
= true;
1155 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1157 /* FIXME: Workaround for PR 80945 - array slices with deferred character
1158 lenghts do not work. Remove this section when the PR is fixed. */
1160 if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
1163 /* End of section to be removed. */
1166 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1169 /* Find the iterators belonging to each variable and check conditions. */
1170 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1172 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1173 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1176 start
= ref
->u
.ar
.start
[i
];
1177 gfc_simplify_expr (start
, 0);
1178 switch (start
->expr_type
)
1182 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1186 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1187 if (!stack_top
|| !stack_top
->iter
1188 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1190 /* Check for (a(i,i), i=1,3). */
1194 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1201 iters
[i
] = stack_top
->iter
;
1202 stack_top
= stack_top
->prev
;
1210 switch (start
->value
.op
.op
)
1212 case INTRINSIC_PLUS
:
1213 case INTRINSIC_TIMES
:
1214 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1215 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1217 case INTRINSIC_MINUS
:
1218 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1219 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1220 || start
->value
.op
.op1
->ref
)
1222 if (!stack_top
|| !stack_top
->iter
1223 || stack_top
->iter
->var
->symtree
1224 != start
->value
.op
.op1
->symtree
)
1226 iters
[i
] = stack_top
->iter
;
1227 stack_top
= stack_top
->prev
;
1239 /* Create new expr. */
1240 new_e
= gfc_copy_expr (curr
->expr1
);
1241 new_e
->expr_type
= EXPR_VARIABLE
;
1242 new_e
->rank
= future_rank
;
1243 if (curr
->expr1
->shape
)
1244 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1246 /* Assign new starts, ends and strides if necessary. */
1247 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1251 start
= ref
->u
.ar
.start
[i
];
1252 switch (start
->expr_type
)
1255 gfc_internal_error ("bad expression");
1258 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1259 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1260 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1261 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1262 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1263 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1266 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1267 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1268 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1269 expr
= gfc_copy_expr (start
);
1270 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1271 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1272 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1273 expr
= gfc_copy_expr (start
);
1274 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1275 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1276 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1277 switch (start
->value
.op
.op
)
1279 case INTRINSIC_MINUS
:
1280 case INTRINSIC_PLUS
:
1281 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1283 case INTRINSIC_TIMES
:
1284 expr
= gfc_copy_expr (start
);
1285 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1286 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1287 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1290 gfc_internal_error ("bad op");
1294 gfc_internal_error ("bad expression");
1297 curr
->expr1
= new_e
;
1299 /* Insert modified statement. Check whether the statement needs to be
1300 inserted at the lowest level. */
1301 if (!stack_top
->iter
)
1305 curr
->next
= prev
->next
->next
;
1310 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1311 stack_top
->code
->block
->next
= curr
;
1315 stack_top
->code
->block
->next
= curr
;
1319 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1320 tries to optimize its block. */
1323 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1324 void *data ATTRIBUTE_UNUSED
)
1326 gfc_code
**curr
, *prev
= NULL
;
1327 struct do_stack write
, first
;
1331 || ((*code
)->block
->op
!= EXEC_WRITE
1332 && (*code
)->block
->op
!= EXEC_READ
))
1340 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1342 if ((*curr
)->op
== EXEC_DO
)
1344 first
.prev
= &write
;
1345 first
.iter
= (*curr
)->ext
.iterator
;
1348 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1356 /* Optimize a namespace, including all contained namespaces.
1357 flag_frontend_optimize and flag_fronend_loop_interchange are
1358 handled separately. */
1361 optimize_namespace (gfc_namespace
*ns
)
1363 gfc_namespace
*saved_ns
= gfc_current_ns
;
1365 gfc_current_ns
= ns
;
1368 in_assoc_list
= false;
1369 in_omp_workshare
= false;
1371 if (flag_frontend_optimize
)
1373 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1374 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1375 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1376 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1377 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1378 if (flag_inline_matmul_limit
!= 0)
1384 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1389 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1391 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1396 if (flag_frontend_loop_interchange
)
1397 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1400 /* BLOCKs are handled in the expression walker below. */
1401 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1403 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1404 optimize_namespace (ns
);
1406 gfc_current_ns
= saved_ns
;
1409 /* Handle dependencies for allocatable strings which potentially redefine
1410 themselves in an assignment. */
1413 realloc_strings (gfc_namespace
*ns
)
1416 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1418 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1420 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1421 realloc_strings (ns
);
1427 optimize_reduction (gfc_namespace
*ns
)
1430 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1431 callback_reduction
, NULL
);
1433 /* BLOCKs are handled in the expression walker below. */
1434 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1436 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1437 optimize_reduction (ns
);
1441 /* Replace code like
1444 a = matmul(b,c) ; a = a + d
1445 where the array function is not elemental and not allocatable
1446 and does not depend on the left-hand side.
1450 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1458 if (e
->expr_type
== EXPR_OP
)
1460 switch (e
->value
.op
.op
)
1462 /* Unary operators and exponentiation: Only look at a single
1465 case INTRINSIC_UPLUS
:
1466 case INTRINSIC_UMINUS
:
1467 case INTRINSIC_PARENTHESES
:
1468 case INTRINSIC_POWER
:
1469 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1473 case INTRINSIC_CONCAT
:
1474 /* Do not do string concatenations. */
1478 /* Binary operators. */
1479 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1482 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1488 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1489 && ! (e
->value
.function
.esym
1490 && (e
->value
.function
.esym
->attr
.elemental
1491 || e
->value
.function
.esym
->attr
.allocatable
1492 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1493 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1494 && ! (e
->value
.function
.isym
1495 && (e
->value
.function
.isym
->elemental
1496 || e
->ts
.type
!= c
->expr1
->ts
.type
1497 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1498 && ! gfc_inline_intrinsic_function_p (e
))
1504 /* Insert a new assignment statement after the current one. */
1505 n
= XCNEW (gfc_code
);
1506 n
->op
= EXEC_ASSIGN
;
1511 n
->expr1
= gfc_copy_expr (c
->expr1
);
1512 n
->expr2
= c
->expr2
;
1513 new_expr
= gfc_copy_expr (c
->expr1
);
1521 /* Nothing to optimize. */
1525 /* Remove unneeded TRIMs at the end of expressions. */
1528 remove_trim (gfc_expr
*rhs
)
1536 /* Check for a // b // trim(c). Looping is probably not
1537 necessary because the parser usually generates
1538 (// (// a b ) trim(c) ) , but better safe than sorry. */
1540 while (rhs
->expr_type
== EXPR_OP
1541 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1542 rhs
= rhs
->value
.op
.op2
;
1544 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1545 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1547 strip_function_call (rhs
);
1548 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1556 /* Optimizations for an assignment. */
1559 optimize_assignment (gfc_code
* c
)
1561 gfc_expr
*lhs
, *rhs
;
1566 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1568 /* Optimize a = trim(b) to a = b. */
1571 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1572 if (is_empty_string (rhs
))
1573 rhs
->value
.character
.length
= 0;
1576 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1577 optimize_binop_array_assignment (c
, &rhs
, false);
1581 /* Remove an unneeded function call, modifying the expression.
1582 This replaces the function call with the value of its
1583 first argument. The rest of the argument list is freed. */
1586 strip_function_call (gfc_expr
*e
)
1589 gfc_actual_arglist
*a
;
1591 a
= e
->value
.function
.actual
;
1593 /* We should have at least one argument. */
1594 gcc_assert (a
->expr
!= NULL
);
1598 /* Free the remaining arglist, if any. */
1600 gfc_free_actual_arglist (a
->next
);
1602 /* Graft the argument expression onto the original function. */
1608 /* Optimization of lexical comparison functions. */
1611 optimize_lexical_comparison (gfc_expr
*e
)
1613 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1616 switch (e
->value
.function
.isym
->id
)
1619 return optimize_comparison (e
, INTRINSIC_LE
);
1622 return optimize_comparison (e
, INTRINSIC_GE
);
1625 return optimize_comparison (e
, INTRINSIC_GT
);
1628 return optimize_comparison (e
, INTRINSIC_LT
);
1636 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1637 do CHARACTER because of possible pessimization involving character
1641 combine_array_constructor (gfc_expr
*e
)
1644 gfc_expr
*op1
, *op2
;
1647 gfc_constructor
*c
, *new_c
;
1648 gfc_constructor_base oldbase
, newbase
;
1653 /* Array constructors have rank one. */
1657 /* Don't try to combine association lists, this makes no sense
1658 and leads to an ICE. */
1662 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1663 if (forall_level
> 0)
1666 /* Inside an iterator, things can get hairy; we are likely to create
1667 an invalid temporary variable. */
1668 if (iterator_level
> 0)
1671 op1
= e
->value
.op
.op1
;
1672 op2
= e
->value
.op
.op2
;
1677 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1678 scalar_first
= false;
1679 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1681 scalar_first
= true;
1682 op1
= e
->value
.op
.op2
;
1683 op2
= e
->value
.op
.op1
;
1688 if (op2
->ts
.type
== BT_CHARACTER
)
1691 /* This might be an expanded constructor with very many constant values. If
1692 we perform the operation here, we might end up with a long compile time
1693 and actually longer execution time, so a length bound is in order here.
1694 If the constructor constains something which is not a constant, it did
1695 not come from an expansion, so leave it alone. */
1697 #define CONSTR_LEN_MAX 4
1699 oldbase
= op1
->value
.constructor
;
1703 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1705 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1713 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1716 #undef CONSTR_LEN_MAX
1719 e
->expr_type
= EXPR_ARRAY
;
1721 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1723 for (c
= gfc_constructor_first (oldbase
); c
;
1724 c
= gfc_constructor_next (c
))
1726 new_expr
= gfc_get_expr ();
1727 new_expr
->ts
= e
->ts
;
1728 new_expr
->expr_type
= EXPR_OP
;
1729 new_expr
->rank
= c
->expr
->rank
;
1730 new_expr
->where
= c
->expr
->where
;
1731 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1735 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1736 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1740 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1741 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1744 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1745 new_c
->iterator
= c
->iterator
;
1749 gfc_free_expr (op1
);
1750 gfc_free_expr (op2
);
1751 gfc_free_expr (scalar
);
1753 e
->value
.constructor
= newbase
;
1757 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1758 2**k into ishift(1,k) */
1761 optimize_power (gfc_expr
*e
)
1763 gfc_expr
*op1
, *op2
;
1764 gfc_expr
*iand
, *ishft
;
1766 if (e
->ts
.type
!= BT_INTEGER
)
1769 op1
= e
->value
.op
.op1
;
1771 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1774 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1776 gfc_free_expr (op1
);
1778 op2
= e
->value
.op
.op2
;
1783 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1784 "_internal_iand", e
->where
, 2, op2
,
1785 gfc_get_int_expr (e
->ts
.kind
,
1788 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1789 "_internal_ishft", e
->where
, 2, iand
,
1790 gfc_get_int_expr (e
->ts
.kind
,
1793 e
->value
.op
.op
= INTRINSIC_MINUS
;
1794 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1795 e
->value
.op
.op2
= ishft
;
1798 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1800 gfc_free_expr (op1
);
1802 op2
= e
->value
.op
.op2
;
1806 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1807 "_internal_ishft", e
->where
, 2,
1808 gfc_get_int_expr (e
->ts
.kind
,
1815 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1817 op2
= e
->value
.op
.op2
;
1821 gfc_free_expr (op1
);
1822 gfc_free_expr (op2
);
1824 e
->expr_type
= EXPR_CONSTANT
;
1825 e
->value
.op
.op1
= NULL
;
1826 e
->value
.op
.op2
= NULL
;
1827 mpz_init_set_si (e
->value
.integer
, 1);
1828 /* Typespec and location are still OK. */
1835 /* Recursive optimization of operators. */
1838 optimize_op (gfc_expr
*e
)
1842 gfc_intrinsic_op op
= e
->value
.op
.op
;
1846 /* Only use new-style comparisons. */
1849 case INTRINSIC_EQ_OS
:
1853 case INTRINSIC_GE_OS
:
1857 case INTRINSIC_LE_OS
:
1861 case INTRINSIC_NE_OS
:
1865 case INTRINSIC_GT_OS
:
1869 case INTRINSIC_LT_OS
:
1885 changed
= optimize_comparison (e
, op
);
1888 /* Look at array constructors. */
1889 case INTRINSIC_PLUS
:
1890 case INTRINSIC_MINUS
:
1891 case INTRINSIC_TIMES
:
1892 case INTRINSIC_DIVIDE
:
1893 return combine_array_constructor (e
) || changed
;
1895 case INTRINSIC_POWER
:
1896 return optimize_power (e
);
1906 /* Return true if a constant string contains only blanks. */
1909 is_empty_string (gfc_expr
*e
)
1913 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1916 for (i
=0; i
< e
->value
.character
.length
; i
++)
1918 if (e
->value
.character
.string
[i
] != ' ')
1926 /* Insert a call to the intrinsic len_trim. Use a different name for
1927 the symbol tree so we don't run into trouble when the user has
1928 renamed len_trim for some reason. */
1931 get_len_trim_call (gfc_expr
*str
, int kind
)
1934 gfc_actual_arglist
*actual_arglist
, *next
;
1936 fcn
= gfc_get_expr ();
1937 fcn
->expr_type
= EXPR_FUNCTION
;
1938 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1939 actual_arglist
= gfc_get_actual_arglist ();
1940 actual_arglist
->expr
= str
;
1941 next
= gfc_get_actual_arglist ();
1942 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1943 actual_arglist
->next
= next
;
1945 fcn
->value
.function
.actual
= actual_arglist
;
1946 fcn
->where
= str
->where
;
1947 fcn
->ts
.type
= BT_INTEGER
;
1948 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1950 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1951 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1952 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1953 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1954 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1955 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1956 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1957 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1962 /* Optimize expressions for equality. */
1965 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1967 gfc_expr
*op1
, *op2
;
1971 gfc_actual_arglist
*firstarg
, *secondarg
;
1973 if (e
->expr_type
== EXPR_OP
)
1977 op1
= e
->value
.op
.op1
;
1978 op2
= e
->value
.op
.op2
;
1980 else if (e
->expr_type
== EXPR_FUNCTION
)
1982 /* One of the lexical comparison functions. */
1983 firstarg
= e
->value
.function
.actual
;
1984 secondarg
= firstarg
->next
;
1985 op1
= firstarg
->expr
;
1986 op2
= secondarg
->expr
;
1991 /* Strip off unneeded TRIM calls from string comparisons. */
1993 change
= remove_trim (op1
);
1995 if (remove_trim (op2
))
1998 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1999 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2000 handles them well). However, there are also cases that need a non-scalar
2001 argument. For example the any intrinsic. See PR 45380. */
2005 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2007 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2008 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2010 bool empty_op1
, empty_op2
;
2011 empty_op1
= is_empty_string (op1
);
2012 empty_op2
= is_empty_string (op2
);
2014 if (empty_op1
|| empty_op2
)
2020 /* This can only happen when an error for comparing
2021 characters of different kinds has already been issued. */
2022 if (empty_op1
&& empty_op2
)
2025 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2026 str
= empty_op1
? op2
: op1
;
2028 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2032 gfc_free_expr (op1
);
2034 gfc_free_expr (op2
);
2038 e
->value
.op
.op1
= fcn
;
2039 e
->value
.op
.op2
= zero
;
2044 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2046 if (flag_finite_math_only
2047 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2048 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2050 eq
= gfc_dep_compare_expr (op1
, op2
);
2053 /* Replace A // B < A // C with B < C, and A // B < C // B
2055 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2056 && op1
->expr_type
== EXPR_OP
2057 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2058 && op2
->expr_type
== EXPR_OP
2059 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2061 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2062 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2063 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2064 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2066 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2068 /* Watch out for 'A ' // x vs. 'A' // x. */
2070 if (op1_left
->expr_type
== EXPR_CONSTANT
2071 && op2_left
->expr_type
== EXPR_CONSTANT
2072 && op1_left
->value
.character
.length
2073 != op2_left
->value
.character
.length
)
2081 firstarg
->expr
= op1_right
;
2082 secondarg
->expr
= op2_right
;
2086 e
->value
.op
.op1
= op1_right
;
2087 e
->value
.op
.op2
= op2_right
;
2089 optimize_comparison (e
, op
);
2093 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2099 firstarg
->expr
= op1_left
;
2100 secondarg
->expr
= op2_left
;
2104 e
->value
.op
.op1
= op1_left
;
2105 e
->value
.op
.op2
= op2_left
;
2108 optimize_comparison (e
, op
);
2115 /* eq can only be -1, 0 or 1 at this point. */
2143 gfc_internal_error ("illegal OP in optimize_comparison");
2147 /* Replace the expression by a constant expression. The typespec
2148 and where remains the way it is. */
2151 e
->expr_type
= EXPR_CONSTANT
;
2152 e
->value
.logical
= result
;
2160 /* Optimize a trim function by replacing it with an equivalent substring
2161 involving a call to len_trim. This only works for expressions where
2162 variables are trimmed. Return true if anything was modified. */
2165 optimize_trim (gfc_expr
*e
)
2170 gfc_ref
**rr
= NULL
;
2172 /* Don't do this optimization within an argument list, because
2173 otherwise aliasing issues may occur. */
2175 if (count_arglist
!= 1)
2178 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2179 || e
->value
.function
.isym
== NULL
2180 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2183 a
= e
->value
.function
.actual
->expr
;
2185 if (a
->expr_type
!= EXPR_VARIABLE
)
2188 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2190 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2193 /* Follow all references to find the correct place to put the newly
2194 created reference. FIXME: Also handle substring references and
2195 array references. Array references cause strange regressions at
2200 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2202 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2207 strip_function_call (e
);
2212 /* Create the reference. */
2214 ref
= gfc_get_ref ();
2215 ref
->type
= REF_SUBSTRING
;
2217 /* Set the start of the reference. */
2219 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2221 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2223 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
2225 /* Set the end of the reference to the call to len_trim. */
2227 ref
->u
.ss
.end
= fcn
;
2228 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2233 /* Optimize minloc(b), where b is rank 1 array, into
2234 (/ minloc(b, dim=1) /), and similarly for maxloc,
2235 as the latter forms are expanded inline. */
2238 optimize_minmaxloc (gfc_expr
**e
)
2241 gfc_actual_arglist
*a
;
2245 || fn
->value
.function
.actual
== NULL
2246 || fn
->value
.function
.actual
->expr
== NULL
2247 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2250 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2251 (*e
)->shape
= fn
->shape
;
2254 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2256 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2257 strcpy (name
, fn
->value
.function
.name
);
2258 p
= strstr (name
, "loc0");
2260 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2261 if (fn
->value
.function
.actual
->next
)
2263 a
= fn
->value
.function
.actual
->next
;
2264 gcc_assert (a
->expr
== NULL
);
2268 a
= gfc_get_actual_arglist ();
2269 fn
->value
.function
.actual
->next
= a
;
2271 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2273 mpz_set_ui (a
->expr
->value
.integer
, 1);
2276 /* Callback function for code checking that we do not pass a DO variable to an
2277 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2280 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2281 void *data ATTRIBUTE_UNUSED
)
2285 gfc_formal_arglist
*f
;
2286 gfc_actual_arglist
*a
;
2293 /* If the doloop_list grew, we have to truncate it here. */
2295 if ((unsigned) doloop_level
< doloop_list
.length())
2296 doloop_list
.truncate (doloop_level
);
2303 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2308 loop
.branch_level
= if_level
+ select_level
;
2309 loop
.seen_goto
= false;
2310 doloop_list
.safe_push (loop
);
2313 /* If anything could transfer control away from a suspicious
2314 subscript, make sure to set seen_goto in the current DO loop
2319 case EXEC_ERROR_STOP
:
2325 if (co
->ext
.open
->err
)
2330 if (co
->ext
.close
->err
)
2334 case EXEC_BACKSPACE
:
2339 if (co
->ext
.filepos
->err
)
2344 if (co
->ext
.filepos
->err
)
2350 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2355 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2356 loop
.seen_goto
= true;
2361 if (co
->resolved_sym
== NULL
)
2364 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2366 /* Withot a formal arglist, there is only unknown INTENT,
2367 which we don't check for. */
2375 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2383 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2385 if (a
->expr
&& a
->expr
->symtree
2386 && a
->expr
->symtree
->n
.sym
== do_sym
)
2388 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2389 gfc_error_now ("Variable %qs at %L set to undefined "
2390 "value inside loop beginning at %L as "
2391 "INTENT(OUT) argument to subroutine %qs",
2392 do_sym
->name
, &a
->expr
->where
,
2393 &(doloop_list
[i
].c
->loc
),
2394 co
->symtree
->n
.sym
->name
);
2395 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2396 gfc_error_now ("Variable %qs at %L not definable inside "
2397 "loop beginning at %L as INTENT(INOUT) "
2398 "argument to subroutine %qs",
2399 do_sym
->name
, &a
->expr
->where
,
2400 &(doloop_list
[i
].c
->loc
),
2401 co
->symtree
->n
.sym
->name
);
2412 if (seen_goto
&& doloop_level
> 0)
2413 doloop_list
[doloop_level
-1].seen_goto
= true;
2418 /* Callback function to warn about different things within DO loops. */
2421 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2422 void *data ATTRIBUTE_UNUSED
)
2426 if (doloop_list
.length () == 0)
2429 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2432 last
= &doloop_list
.last();
2433 if (last
->seen_goto
&& !warn_do_subscript
)
2436 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2448 /* Callback function - if the expression is the variable in data->sym,
2449 replace it with a constant from data->val. */
2452 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2459 if (ex
->expr_type
!= EXPR_VARIABLE
)
2462 d
= (insert_index_t
*) data
;
2463 if (ex
->symtree
->n
.sym
!= d
->sym
)
2466 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2467 mpz_set (n
->value
.integer
, d
->val
);
2474 /* In the expression e, replace occurrences of the variable sym with
2475 val. If this results in a constant expression, return true and
2476 return the value in ret. Return false if the expression already
2477 is a constant. Caller has to clear ret in that case. */
2480 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2483 insert_index_t data
;
2486 if (e
->expr_type
== EXPR_CONSTANT
)
2489 n
= gfc_copy_expr (e
);
2491 mpz_init_set (data
.val
, val
);
2492 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2493 gfc_simplify_expr (n
, 0);
2495 if (n
->expr_type
== EXPR_CONSTANT
)
2498 mpz_init_set (ret
, n
->value
.integer
);
2503 mpz_clear (data
.val
);
2509 /* Check array subscripts for possible out-of-bounds accesses in DO
2510 loops with constant bounds. */
2513 do_subscript (gfc_expr
**e
)
2523 /* Constants are already checked. */
2524 if (v
->expr_type
== EXPR_CONSTANT
)
2527 /* Wrong warnings will be generated in an associate list. */
2531 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2533 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2536 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2539 mpz_t do_start
, do_step
, do_end
;
2540 bool have_do_start
, have_do_end
;
2541 bool error_not_proven
;
2548 /* If we are within a branch, or a goto or equivalent
2549 was seen in the DO loop before, then we cannot prove that
2550 this expression is actually evaluated. Don't do anything
2551 unless we want to see it all. */
2552 error_not_proven
= lp
->seen_goto
2553 || lp
->branch_level
< if_level
+ select_level
;
2555 if (error_not_proven
&& !warn_do_subscript
)
2558 if (error_not_proven
)
2559 warn
= OPT_Wdo_subscript
;
2563 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2564 if (do_sym
->ts
.type
!= BT_INTEGER
)
2567 /* If we do not know about the stepsize, the loop may be zero trip.
2568 Do not warn in this case. */
2570 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2571 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2575 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2577 have_do_start
= true;
2578 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2581 have_do_start
= false;
2584 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2587 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2590 have_do_end
= false;
2592 if (!have_do_start
&& !have_do_end
)
2595 /* May have to correct the end value if the step does not equal
2597 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2603 mpz_sub (diff
, do_end
, do_start
);
2604 mpz_tdiv_r (rem
, diff
, do_step
);
2605 mpz_sub (do_end
, do_end
, rem
);
2610 for (i
= 0; i
< ar
->dimen
; i
++)
2613 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2614 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2616 if (ar
->as
->lower
[i
]
2617 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2618 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2619 gfc_warning (warn
, "Array reference at %L out of bounds "
2620 "(%ld < %ld) in loop beginning at %L",
2621 &ar
->start
[i
]->where
, mpz_get_si (val
),
2622 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2623 &doloop_list
[j
].c
->loc
);
2625 if (ar
->as
->upper
[i
]
2626 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2627 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2628 gfc_warning (warn
, "Array reference at %L out of bounds "
2629 "(%ld > %ld) in loop beginning at %L",
2630 &ar
->start
[i
]->where
, mpz_get_si (val
),
2631 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2632 &doloop_list
[j
].c
->loc
);
2637 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2638 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2640 if (ar
->as
->lower
[i
]
2641 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2642 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2643 gfc_warning (warn
, "Array reference at %L out of bounds "
2644 "(%ld < %ld) in loop beginning at %L",
2645 &ar
->start
[i
]->where
, mpz_get_si (val
),
2646 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2647 &doloop_list
[j
].c
->loc
);
2649 if (ar
->as
->upper
[i
]
2650 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2651 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2652 gfc_warning (warn
, "Array reference at %L out of bounds "
2653 "(%ld > %ld) in loop beginning at %L",
2654 &ar
->start
[i
]->where
, mpz_get_si (val
),
2655 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2656 &doloop_list
[j
].c
->loc
);
2666 /* Function for functions checking that we do not pass a DO variable
2667 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2670 do_intent (gfc_expr
**e
)
2672 gfc_formal_arglist
*f
;
2673 gfc_actual_arglist
*a
;
2680 if (expr
->expr_type
!= EXPR_FUNCTION
)
2683 /* Intrinsic functions don't modify their arguments. */
2685 if (expr
->value
.function
.isym
)
2688 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2690 /* Without a formal arglist, there is only unknown INTENT,
2691 which we don't check for. */
2695 a
= expr
->value
.function
.actual
;
2699 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2706 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2708 if (a
->expr
&& a
->expr
->symtree
2709 && a
->expr
->symtree
->n
.sym
== do_sym
)
2711 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2712 gfc_error_now ("Variable %qs at %L set to undefined value "
2713 "inside loop beginning at %L as INTENT(OUT) "
2714 "argument to function %qs", do_sym
->name
,
2715 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2716 expr
->symtree
->n
.sym
->name
);
2717 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2718 gfc_error_now ("Variable %qs at %L not definable inside loop"
2719 " beginning at %L as INTENT(INOUT) argument to"
2720 " function %qs", do_sym
->name
,
2721 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2722 expr
->symtree
->n
.sym
->name
);
2733 doloop_warn (gfc_namespace
*ns
)
2735 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2738 /* This selction deals with inlining calls to MATMUL. */
2740 /* Replace calls to matmul outside of straight assignments with a temporary
2741 variable so that later inlining will work. */
2744 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2748 bool *found
= (bool *) data
;
2752 if (e
->expr_type
!= EXPR_FUNCTION
2753 || e
->value
.function
.isym
== NULL
2754 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2757 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2761 /* Check if this is already in the form c = matmul(a,b). */
2763 if ((*current_code
)->expr2
== e
)
2766 n
= create_var (e
, "matmul");
2768 /* If create_var is unable to create a variable (for example if
2769 -fno-realloc-lhs is in force with a variable that does not have bounds
2770 known at compile-time), just return. */
2780 /* Set current_code and associated variables so that matmul_to_var_expr can
2784 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2785 void *data ATTRIBUTE_UNUSED
)
2787 if (current_code
!= c
)
2790 inserted_block
= NULL
;
2791 changed_statement
= NULL
;
2798 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2799 for a and b if there is a dependency between the arguments and the
2800 result variable or if a or b are the result of calculations that cannot
2801 be handled by the inliner. */
2804 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2805 void *data ATTRIBUTE_UNUSED
)
2807 gfc_expr
*expr1
, *expr2
;
2809 gfc_actual_arglist
*a
, *b
;
2811 gfc_expr
*matrix_a
, *matrix_b
;
2812 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2816 if (co
->op
!= EXEC_ASSIGN
)
2819 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2823 /* This has some duplication with inline_matmul_assign. This
2824 is because the creation of temporary variables could still fail,
2825 and inline_matmul_assign still needs to be able to handle these
2830 if (expr2
->expr_type
!= EXPR_FUNCTION
2831 || expr2
->value
.function
.isym
== NULL
2832 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2836 a
= expr2
->value
.function
.actual
;
2837 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2838 if (matrix_a
!= NULL
)
2840 if (matrix_a
->expr_type
== EXPR_VARIABLE
2841 && (gfc_check_dependency (matrix_a
, expr1
, true)
2842 || has_dimen_vector_ref (matrix_a
)))
2850 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2851 if (matrix_b
!= NULL
)
2853 if (matrix_b
->expr_type
== EXPR_VARIABLE
2854 && (gfc_check_dependency (matrix_b
, expr1
, true)
2855 || has_dimen_vector_ref (matrix_b
)))
2861 if (!a_tmp
&& !b_tmp
)
2865 inserted_block
= NULL
;
2866 changed_statement
= NULL
;
2870 at
= create_var (a
->expr
,"mma");
2877 bt
= create_var (b
->expr
,"mmb");
2884 /* Auxiliary function to build and simplify an array inquiry function.
2885 dim is zero-based. */
2888 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2891 gfc_expr
*dim_arg
, *kind
;
2897 case GFC_ISYM_LBOUND
:
2898 name
= "_gfortran_lbound";
2901 case GFC_ISYM_UBOUND
:
2902 name
= "_gfortran_ubound";
2906 name
= "_gfortran_size";
2913 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2914 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2915 gfc_index_integer_kind
);
2917 ec
= gfc_copy_expr (e
);
2918 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2920 gfc_simplify_expr (fcn
, 0);
2924 /* Builds a logical expression. */
2927 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2932 ts
.type
= BT_LOGICAL
;
2933 ts
.kind
= gfc_default_logical_kind
;
2934 res
= gfc_get_expr ();
2935 res
->where
= e1
->where
;
2936 res
->expr_type
= EXPR_OP
;
2937 res
->value
.op
.op
= op
;
2938 res
->value
.op
.op1
= e1
;
2939 res
->value
.op
.op2
= e2
;
2946 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2947 compatible typespecs. */
2950 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2954 res
= gfc_get_expr ();
2956 res
->where
= e1
->where
;
2957 res
->expr_type
= EXPR_OP
;
2958 res
->value
.op
.op
= op
;
2959 res
->value
.op
.op1
= e1
;
2960 res
->value
.op
.op2
= e2
;
2961 gfc_simplify_expr (res
, 0);
2965 /* Generate the IF statement for a runtime check if we want to do inlining or
2966 not - putting in the code for both branches and putting it into the syntax
2967 tree is the caller's responsibility. For fixed array sizes, this should be
2968 removed by DCE. Only called for rank-two matrices A and B. */
2971 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2973 gfc_expr
*inline_limit
;
2974 gfc_code
*if_1
, *if_2
, *else_2
;
2975 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2979 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2981 /* Calculation is done in real to avoid integer overflow. */
2983 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2985 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2987 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2990 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2991 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2992 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2996 ts
.kind
= gfc_default_real_kind
;
2997 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2998 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2999 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3001 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3002 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3004 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3005 gfc_simplify_expr (cond
, 0);
3007 else_2
= XCNEW (gfc_code
);
3008 else_2
->op
= EXEC_IF
;
3009 else_2
->loc
= a
->where
;
3011 if_2
= XCNEW (gfc_code
);
3014 if_2
->loc
= a
->where
;
3015 if_2
->block
= else_2
;
3017 if_1
= XCNEW (gfc_code
);
3020 if_1
->loc
= a
->where
;
3026 /* Insert code to issue a runtime error if the expressions are not equal. */
3029 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3032 gfc_code
*if_1
, *if_2
;
3034 gfc_actual_arglist
*a1
, *a2
, *a3
;
3036 gcc_assert (e1
->where
.lb
);
3037 /* Build the call to runtime_error. */
3038 c
= XCNEW (gfc_code
);
3042 /* Get a null-terminated message string. */
3044 a1
= gfc_get_actual_arglist ();
3045 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3046 msg
, strlen(msg
)+1);
3049 /* Pass the value of the first expression. */
3050 a2
= gfc_get_actual_arglist ();
3051 a2
->expr
= gfc_copy_expr (e1
);
3054 /* Pass the value of the second expression. */
3055 a3
= gfc_get_actual_arglist ();
3056 a3
->expr
= gfc_copy_expr (e2
);
3059 gfc_check_fe_runtime_error (c
->ext
.actual
);
3060 gfc_resolve_fe_runtime_error (c
);
3062 if_2
= XCNEW (gfc_code
);
3064 if_2
->loc
= e1
->where
;
3067 if_1
= XCNEW (gfc_code
);
3070 if_1
->loc
= e1
->where
;
3072 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3073 gfc_simplify_expr (cond
, 0);
3079 /* Handle matrix reallocation. Caller is responsible to insert into
3082 For the two-dimensional case, build
3084 if (allocated(c)) then
3085 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3087 allocate (c(size(a,1), size(b,2)))
3090 allocate (c(size(a,1),size(b,2)))
3093 and for the other cases correspondingly.
3097 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3098 enum matrix_case m_case
)
3101 gfc_expr
*allocated
, *alloc_expr
;
3102 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3103 gfc_code
*else_alloc
;
3104 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3106 gfc_expr
*cond
, *ne1
, *ne2
;
3108 if (warn_realloc_lhs
)
3109 gfc_warning (OPT_Wrealloc_lhs
,
3110 "Code for reallocating the allocatable array at %L will "
3111 "be added", &c
->where
);
3113 alloc_expr
= gfc_copy_expr (c
);
3115 ar
= gfc_find_array_ref (alloc_expr
);
3116 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3118 /* c comes in as a full ref. Change it into a copy and make it into an
3119 element ref so it has the right form for for ALLOCATE. In the same
3120 switch statement, also generate the size comparison for the secod IF
3123 ar
->type
= AR_ELEMENT
;
3128 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3129 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3130 ne1
= build_logical_expr (INTRINSIC_NE
,
3131 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3132 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3133 ne2
= build_logical_expr (INTRINSIC_NE
,
3134 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3135 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3136 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3140 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3141 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3143 ne1
= build_logical_expr (INTRINSIC_NE
,
3144 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3145 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3146 ne2
= build_logical_expr (INTRINSIC_NE
,
3147 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3148 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3149 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3154 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3155 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3157 ne1
= build_logical_expr (INTRINSIC_NE
,
3158 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3159 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3160 ne2
= build_logical_expr (INTRINSIC_NE
,
3161 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3162 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3163 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3167 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3168 cond
= build_logical_expr (INTRINSIC_NE
,
3169 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3170 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3174 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3175 cond
= build_logical_expr (INTRINSIC_NE
,
3176 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3177 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3185 gfc_simplify_expr (cond
, 0);
3187 /* We need two identical allocate statements in two
3188 branches of the IF statement. */
3190 allocate1
= XCNEW (gfc_code
);
3191 allocate1
->op
= EXEC_ALLOCATE
;
3192 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3193 allocate1
->loc
= c
->where
;
3194 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3196 allocate_else
= XCNEW (gfc_code
);
3197 allocate_else
->op
= EXEC_ALLOCATE
;
3198 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3199 allocate_else
->loc
= c
->where
;
3200 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3202 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3203 "_gfortran_allocated", c
->where
,
3204 1, gfc_copy_expr (c
));
3206 deallocate
= XCNEW (gfc_code
);
3207 deallocate
->op
= EXEC_DEALLOCATE
;
3208 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3209 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3210 deallocate
->next
= allocate1
;
3211 deallocate
->loc
= c
->where
;
3213 if_size_2
= XCNEW (gfc_code
);
3214 if_size_2
->op
= EXEC_IF
;
3215 if_size_2
->expr1
= cond
;
3216 if_size_2
->loc
= c
->where
;
3217 if_size_2
->next
= deallocate
;
3219 if_size_1
= XCNEW (gfc_code
);
3220 if_size_1
->op
= EXEC_IF
;
3221 if_size_1
->block
= if_size_2
;
3222 if_size_1
->loc
= c
->where
;
3224 else_alloc
= XCNEW (gfc_code
);
3225 else_alloc
->op
= EXEC_IF
;
3226 else_alloc
->loc
= c
->where
;
3227 else_alloc
->next
= allocate_else
;
3229 if_alloc_2
= XCNEW (gfc_code
);
3230 if_alloc_2
->op
= EXEC_IF
;
3231 if_alloc_2
->expr1
= allocated
;
3232 if_alloc_2
->loc
= c
->where
;
3233 if_alloc_2
->next
= if_size_1
;
3234 if_alloc_2
->block
= else_alloc
;
3236 if_alloc_1
= XCNEW (gfc_code
);
3237 if_alloc_1
->op
= EXEC_IF
;
3238 if_alloc_1
->block
= if_alloc_2
;
3239 if_alloc_1
->loc
= c
->where
;
3244 /* Callback function for has_function_or_op. */
3247 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3248 void *data ATTRIBUTE_UNUSED
)
3253 return (*e
)->expr_type
== EXPR_FUNCTION
3254 || (*e
)->expr_type
== EXPR_OP
;
3257 /* Returns true if the expression contains a function. */
3260 has_function_or_op (gfc_expr
**e
)
3265 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3268 /* Freeze (assign to a temporary variable) a single expression. */
3271 freeze_expr (gfc_expr
**ep
)
3274 if (has_function_or_op (ep
))
3276 ne
= create_var (*ep
, "freeze");
3281 /* Go through an expression's references and assign them to temporary
3282 variables if they contain functions. This is usually done prior to
3283 front-end scalarization to avoid multiple invocations of functions. */
3286 freeze_references (gfc_expr
*e
)
3292 for (r
=e
->ref
; r
; r
=r
->next
)
3294 if (r
->type
== REF_SUBSTRING
)
3296 if (r
->u
.ss
.start
!= NULL
)
3297 freeze_expr (&r
->u
.ss
.start
);
3299 if (r
->u
.ss
.end
!= NULL
)
3300 freeze_expr (&r
->u
.ss
.end
);
3302 else if (r
->type
== REF_ARRAY
)
3311 for (i
=0; i
<ar
->dimen
; i
++)
3313 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3315 freeze_expr (&ar
->start
[i
]);
3316 freeze_expr (&ar
->end
[i
]);
3317 freeze_expr (&ar
->stride
[i
]);
3319 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3321 freeze_expr (&ar
->start
[i
]);
3327 for (i
=0; i
<ar
->dimen
; i
++)
3328 freeze_expr (&ar
->start
[i
]);
3338 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3341 convert_to_index_kind (gfc_expr
*e
)
3345 gcc_assert (e
!= NULL
);
3347 res
= gfc_copy_expr (e
);
3349 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3351 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3355 ts
.type
= BT_INTEGER
;
3356 ts
.kind
= gfc_index_integer_kind
;
3358 gfc_convert_type_warn (e
, &ts
, 2, 0);
3364 /* Function to create a DO loop including creation of the
3365 iteration variable. gfc_expr are copied.*/
3368 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3369 gfc_namespace
*ns
, char *vname
)
3372 char name
[GFC_MAX_SYMBOL_LEN
+1];
3373 gfc_symtree
*symtree
;
3378 /* Create an expression for the iteration variable. */
3380 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3382 sprintf (name
, "__var_%d_do", var_num
++);
3385 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3388 /* Create the loop variable. */
3390 symbol
= symtree
->n
.sym
;
3391 symbol
->ts
.type
= BT_INTEGER
;
3392 symbol
->ts
.kind
= gfc_index_integer_kind
;
3393 symbol
->attr
.flavor
= FL_VARIABLE
;
3394 symbol
->attr
.referenced
= 1;
3395 symbol
->attr
.dimension
= 0;
3396 symbol
->attr
.fe_temp
= 1;
3397 gfc_commit_symbol (symbol
);
3399 i
= gfc_get_expr ();
3400 i
->expr_type
= EXPR_VARIABLE
;
3404 i
->symtree
= symtree
;
3406 /* ... and the nested DO statements. */
3407 n
= XCNEW (gfc_code
);
3410 n
->ext
.iterator
= gfc_get_iterator ();
3411 n
->ext
.iterator
->var
= i
;
3412 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3413 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3415 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3417 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3420 n2
= XCNEW (gfc_code
);
3428 /* Get the upper bound of the DO loops for matmul along a dimension. This
3432 get_size_m1 (gfc_expr
*e
, int dimen
)
3437 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3439 res
= gfc_get_constant_expr (BT_INTEGER
,
3440 gfc_index_integer_kind
, &e
->where
);
3441 mpz_sub_ui (res
->value
.integer
, size
, 1);
3446 res
= get_operand (INTRINSIC_MINUS
,
3447 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3448 gfc_get_int_expr (gfc_index_integer_kind
,
3450 gfc_simplify_expr (res
, 0);
3456 /* Function to return a scalarized expression. It is assumed that indices are
3457 zero based to make generation of DO loops easier. A zero as index will
3458 access the first element along a dimension. Single element references will
3459 be skipped. A NULL as an expression will be replaced by a full reference.
3460 This assumes that the index loops have gfc_index_integer_kind, and that all
3461 references have been frozen. */
3464 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3473 e
= gfc_copy_expr(e_in
);
3477 ar
= gfc_find_array_ref (e
);
3479 /* We scalarize count_index variables, reducing the rank by count_index. */
3481 e
->rank
= rank
- count_index
;
3483 was_fullref
= ar
->type
== AR_FULL
;
3486 ar
->type
= AR_ELEMENT
;
3488 ar
->type
= AR_SECTION
;
3490 /* Loop over the indices. For each index, create the expression
3491 index * stride + lbound(e, dim). */
3494 for (i
=0; i
< ar
->dimen
; i
++)
3496 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3498 if (index
[i_index
] != NULL
)
3500 gfc_expr
*lbound
, *nindex
;
3503 loopvar
= gfc_copy_expr (index
[i_index
]);
3509 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3510 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3514 ts
.type
= BT_INTEGER
;
3515 ts
.kind
= gfc_index_integer_kind
;
3516 gfc_convert_type (tmp
, &ts
, 2);
3518 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3523 /* Calculate the lower bound of the expression. */
3526 lbound
= gfc_copy_expr (ar
->start
[i
]);
3527 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3531 ts
.type
= BT_INTEGER
;
3532 ts
.kind
= gfc_index_integer_kind
;
3533 gfc_convert_type (lbound
, &ts
, 2);
3542 lbound_e
= gfc_copy_expr (e_in
);
3544 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3545 if (ref
->type
== REF_ARRAY
3546 && (ref
->u
.ar
.type
== AR_FULL
3547 || ref
->u
.ar
.type
== AR_SECTION
))
3552 gfc_free_ref_list (ref
->next
);
3558 /* Look at full individual sections, like a(:). The first index
3559 is the lbound of a full ref. */
3565 for (j
= 0; j
< ar
->dimen
; j
++)
3567 gfc_free_expr (ar
->start
[j
]);
3568 ar
->start
[j
] = NULL
;
3569 gfc_free_expr (ar
->end
[j
]);
3571 gfc_free_expr (ar
->stride
[j
]);
3572 ar
->stride
[j
] = NULL
;
3575 /* We have to get rid of the shape, if there is one. Do
3576 so by freeing it and calling gfc_resolve to rebuild
3577 it, if necessary. */
3579 if (lbound_e
->shape
)
3580 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3582 lbound_e
->rank
= ar
->dimen
;
3583 gfc_resolve_expr (lbound_e
);
3585 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3587 gfc_free_expr (lbound_e
);
3590 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3592 gfc_free_expr (ar
->start
[i
]);
3593 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3595 gfc_free_expr (ar
->end
[i
]);
3597 gfc_free_expr (ar
->stride
[i
]);
3598 ar
->stride
[i
] = NULL
;
3599 gfc_simplify_expr (ar
->start
[i
], 0);
3601 else if (was_fullref
)
3603 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3612 /* Helper function to check for a dimen vector as subscript. */
3615 has_dimen_vector_ref (gfc_expr
*e
)
3620 ar
= gfc_find_array_ref (e
);
3622 if (ar
->type
== AR_FULL
)
3625 for (i
=0; i
<ar
->dimen
; i
++)
3626 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3632 /* If handed an expression of the form
3636 check if A can be handled by matmul and return if there is an uneven number
3637 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3638 otherwise. The caller has to check for the correct rank. */
3641 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3648 if (e
->expr_type
== EXPR_VARIABLE
)
3650 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3653 else if (e
->expr_type
== EXPR_FUNCTION
)
3655 if (e
->value
.function
.isym
== NULL
)
3658 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3660 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3661 *transpose
= !*transpose
;
3667 e
= e
->value
.function
.actual
->expr
;
3674 /* Inline assignments of the form c = matmul(a,b).
3675 Handle only the cases currently where b and c are rank-two arrays.
3677 This basically translates the code to
3683 do k=0, size(a, 2)-1
3684 do i=0, size(a, 1)-1
3685 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3686 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3687 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3688 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3697 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3698 void *data ATTRIBUTE_UNUSED
)
3701 gfc_expr
*expr1
, *expr2
;
3702 gfc_expr
*matrix_a
, *matrix_b
;
3703 gfc_actual_arglist
*a
, *b
;
3704 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3706 gfc_expr
*u1
, *u2
, *u3
;
3708 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3710 gfc_expr
*var_1
, *var_2
, *var_3
;
3713 gfc_intrinsic_op op_times
, op_plus
;
3714 enum matrix_case m_case
;
3716 gfc_code
*if_limit
= NULL
;
3717 gfc_code
**next_code_point
;
3718 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3720 if (co
->op
!= EXEC_ASSIGN
)
3726 /* The BLOCKS generated for the temporary variables and FORALL don't
3728 if (forall_level
> 0)
3731 /* For now don't do anything in OpenMP workshare, it confuses
3732 its translation, which expects only the allowed statements in there.
3733 We should figure out how to parallelize this eventually. */
3734 if (in_omp_workshare
)
3739 if (expr2
->expr_type
!= EXPR_FUNCTION
3740 || expr2
->value
.function
.isym
== NULL
3741 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3745 inserted_block
= NULL
;
3746 changed_statement
= NULL
;
3748 a
= expr2
->value
.function
.actual
;
3749 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3750 if (matrix_a
== NULL
)
3754 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3755 if (matrix_b
== NULL
)
3758 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3759 || has_dimen_vector_ref (matrix_b
))
3762 /* We do not handle data dependencies yet. */
3763 if (gfc_check_dependency (expr1
, matrix_a
, true)
3764 || gfc_check_dependency (expr1
, matrix_b
, true))
3768 if (matrix_a
->rank
== 2)
3772 if (matrix_b
->rank
== 2 && !transpose_b
)
3777 if (matrix_b
->rank
== 1)
3779 else /* matrix_b->rank == 2 */
3788 else /* matrix_a->rank == 1 */
3790 if (matrix_b
->rank
== 2)
3800 ns
= insert_block ();
3802 /* Assign the type of the zero expression for initializing the resulting
3803 array, and the expression (+ and * for real, integer and complex;
3804 .and. and .or for logical. */
3806 switch(expr1
->ts
.type
)
3809 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3810 op_times
= INTRINSIC_TIMES
;
3811 op_plus
= INTRINSIC_PLUS
;
3815 op_times
= INTRINSIC_AND
;
3816 op_plus
= INTRINSIC_OR
;
3817 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3821 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3823 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3824 op_times
= INTRINSIC_TIMES
;
3825 op_plus
= INTRINSIC_PLUS
;
3829 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3831 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3832 op_times
= INTRINSIC_TIMES
;
3833 op_plus
= INTRINSIC_PLUS
;
3841 current_code
= &ns
->code
;
3843 /* Freeze the references, keeping track of how many temporary variables were
3846 freeze_references (matrix_a
);
3847 freeze_references (matrix_b
);
3848 freeze_references (expr1
);
3851 next_code_point
= current_code
;
3854 next_code_point
= &ns
->code
;
3855 for (i
=0; i
<n_vars
; i
++)
3856 next_code_point
= &(*next_code_point
)->next
;
3859 /* Take care of the inline flag. If the limit check evaluates to a
3860 constant, dead code elimination will eliminate the unneeded branch. */
3862 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3864 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3866 /* Insert the original statement into the else branch. */
3867 if_limit
->block
->block
->next
= co
;
3870 /* ... and the new ones go into the original one. */
3871 *next_code_point
= if_limit
;
3872 next_code_point
= &if_limit
->block
->next
;
3875 assign_zero
= XCNEW (gfc_code
);
3876 assign_zero
->op
= EXEC_ASSIGN
;
3877 assign_zero
->loc
= co
->loc
;
3878 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3879 assign_zero
->expr2
= zero_e
;
3881 /* Handle the reallocation, if needed. */
3882 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3884 gfc_code
*lhs_alloc
;
3886 /* Only need to check a single dimension for the A2B2 case for
3887 bounds checking, the rest will be allocated. Also check this
3890 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3895 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3896 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3897 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3898 "in MATMUL intrinsic: Is %ld, should be %ld");
3899 *next_code_point
= test
;
3900 next_code_point
= &test
->next
;
3904 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3906 *next_code_point
= lhs_alloc
;
3907 next_code_point
= &lhs_alloc
->next
;
3910 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3913 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3915 if (m_case
== A2B2
|| m_case
== A2B1
)
3917 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3918 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3919 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3920 "in MATMUL intrinsic: Is %ld, should be %ld");
3921 *next_code_point
= test
;
3922 next_code_point
= &test
->next
;
3924 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3925 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3928 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3929 "MATMUL intrinsic for dimension 1: "
3930 "is %ld, should be %ld");
3931 else if (m_case
== A2B1
)
3932 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3933 "MATMUL intrinsic: "
3934 "is %ld, should be %ld");
3937 *next_code_point
= test
;
3938 next_code_point
= &test
->next
;
3940 else if (m_case
== A1B2
)
3942 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3943 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3944 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3945 "in MATMUL intrinsic: Is %ld, should be %ld");
3946 *next_code_point
= test
;
3947 next_code_point
= &test
->next
;
3949 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3950 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3952 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3953 "MATMUL intrinsic: "
3954 "is %ld, should be %ld");
3956 *next_code_point
= test
;
3957 next_code_point
= &test
->next
;
3962 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3963 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3964 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3965 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3967 *next_code_point
= test
;
3968 next_code_point
= &test
->next
;
3971 if (m_case
== A2B2T
)
3973 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3974 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3975 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3976 "MATMUL intrinsic for dimension 1: "
3977 "is %ld, should be %ld");
3979 *next_code_point
= test
;
3980 next_code_point
= &test
->next
;
3982 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3983 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3984 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3985 "MATMUL intrinsic for dimension 2: "
3986 "is %ld, should be %ld");
3987 *next_code_point
= test
;
3988 next_code_point
= &test
->next
;
3990 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3991 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3993 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3994 "MATMUL intrnisic for dimension 2: "
3995 "is %ld, should be %ld");
3996 *next_code_point
= test
;
3997 next_code_point
= &test
->next
;
4001 if (m_case
== A2TB2
)
4003 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4004 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4006 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
4007 "MATMUL intrinsic for dimension 1: "
4008 "is %ld, should be %ld");
4010 *next_code_point
= test
;
4011 next_code_point
= &test
->next
;
4013 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4014 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4015 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
4016 "MATMUL intrinsic for dimension 2: "
4017 "is %ld, should be %ld");
4018 *next_code_point
= test
;
4019 next_code_point
= &test
->next
;
4021 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4022 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4024 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
4025 "MATMUL intrnisic for dimension 2: "
4026 "is %ld, should be %ld");
4027 *next_code_point
= test
;
4028 next_code_point
= &test
->next
;
4033 *next_code_point
= assign_zero
;
4035 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4037 assign_matmul
= XCNEW (gfc_code
);
4038 assign_matmul
->op
= EXEC_ASSIGN
;
4039 assign_matmul
->loc
= co
->loc
;
4041 /* Get the bounds for the loops, create them and create the scalarized
4047 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4049 u1
= get_size_m1 (matrix_b
, 2);
4050 u2
= get_size_m1 (matrix_a
, 2);
4051 u3
= get_size_m1 (matrix_a
, 1);
4053 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4054 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4055 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4057 do_1
->block
->next
= do_2
;
4058 do_2
->block
->next
= do_3
;
4059 do_3
->block
->next
= assign_matmul
;
4061 var_1
= do_1
->ext
.iterator
->var
;
4062 var_2
= do_2
->ext
.iterator
->var
;
4063 var_3
= do_3
->ext
.iterator
->var
;
4067 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4071 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4075 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4080 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4082 u1
= get_size_m1 (matrix_b
, 1);
4083 u2
= get_size_m1 (matrix_a
, 2);
4084 u3
= get_size_m1 (matrix_a
, 1);
4086 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4087 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4088 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4090 do_1
->block
->next
= do_2
;
4091 do_2
->block
->next
= do_3
;
4092 do_3
->block
->next
= assign_matmul
;
4094 var_1
= do_1
->ext
.iterator
->var
;
4095 var_2
= do_2
->ext
.iterator
->var
;
4096 var_3
= do_3
->ext
.iterator
->var
;
4100 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4104 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4108 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4113 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4115 u1
= get_size_m1 (matrix_a
, 2);
4116 u2
= get_size_m1 (matrix_b
, 2);
4117 u3
= get_size_m1 (matrix_a
, 1);
4119 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4120 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4121 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4123 do_1
->block
->next
= do_2
;
4124 do_2
->block
->next
= do_3
;
4125 do_3
->block
->next
= assign_matmul
;
4127 var_1
= do_1
->ext
.iterator
->var
;
4128 var_2
= do_2
->ext
.iterator
->var
;
4129 var_3
= do_3
->ext
.iterator
->var
;
4133 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4137 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4141 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4146 u1
= get_size_m1 (matrix_b
, 1);
4147 u2
= 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
);
4152 do_1
->block
->next
= do_2
;
4153 do_2
->block
->next
= assign_matmul
;
4155 var_1
= do_1
->ext
.iterator
->var
;
4156 var_2
= do_2
->ext
.iterator
->var
;
4159 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4163 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4166 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4171 u1
= get_size_m1 (matrix_b
, 2);
4172 u2
= get_size_m1 (matrix_a
, 1);
4174 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4175 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4177 do_1
->block
->next
= do_2
;
4178 do_2
->block
->next
= assign_matmul
;
4180 var_1
= do_1
->ext
.iterator
->var
;
4181 var_2
= do_2
->ext
.iterator
->var
;
4184 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4187 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4191 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4199 /* Build the conjg call around the variables. Set the typespec manually
4200 because gfc_build_intrinsic_call sometimes gets this wrong. */
4205 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4206 matrix_a
->where
, 1, ascalar
);
4214 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4215 matrix_b
->where
, 1, bscalar
);
4218 /* First loop comes after the zero assignment. */
4219 assign_zero
->next
= do_1
;
4221 /* Build the assignment expression in the loop. */
4222 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4224 mult
= get_operand (op_times
, ascalar
, bscalar
);
4225 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4227 /* If we don't want to keep the original statement around in
4228 the else branch, we can free it. */
4230 if (if_limit
== NULL
)
4231 gfc_free_statements(co
);
4235 gfc_free_expr (zero
);
4241 /* Code for index interchange for loops which are grouped together in DO
4242 CONCURRENT or FORALL statements. This is currently only applied if the
4243 iterations are grouped together in a single statement.
4245 For this transformation, it is assumed that memory access in strides is
4246 expensive, and that loops which access later indices (which access memory
4247 in bigger strides) should be moved to the first loops.
4249 For this, a loop over all the statements is executed, counting the times
4250 that the loop iteration values are accessed in each index. The loop
4251 indices are then sorted to minimize access to later indices from inner
4254 /* Type for holding index information. */
4258 gfc_forall_iterator
*fa
;
4260 int n
[GFC_MAX_DIMENSIONS
];
4263 /* Callback function to determine if an expression is the
4264 corresponding variable. */
4267 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4269 gfc_expr
*expr
= *e
;
4272 if (expr
->expr_type
!= EXPR_VARIABLE
)
4275 sym
= (gfc_symbol
*) data
;
4276 return sym
== expr
->symtree
->n
.sym
;
4279 /* Callback function to calculate the cost of a certain index. */
4282 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4292 if (expr
->expr_type
!= EXPR_VARIABLE
)
4296 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4298 if (ref
->type
== REF_ARRAY
)
4304 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4307 ind
= (ind_type
*) data
;
4308 for (i
= 0; i
< ar
->dimen
; i
++)
4310 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4312 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4319 /* Callback function for qsort, to sort the loop indices. */
4322 loop_comp (const void *e1
, const void *e2
)
4324 const ind_type
*i1
= (const ind_type
*) e1
;
4325 const ind_type
*i2
= (const ind_type
*) e2
;
4328 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4330 if (i1
->n
[i
] != i2
->n
[i
])
4331 return i1
->n
[i
] - i2
->n
[i
];
4333 /* All other things being equal, let's not change the ordering. */
4334 return i2
->num
- i1
->num
;
4337 /* Main function to do the index interchange. */
4340 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4341 void *data ATTRIBUTE_UNUSED
)
4346 gfc_forall_iterator
*fa
;
4350 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4354 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4357 /* Nothing to reorder. */
4361 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4364 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4366 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4368 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4373 ind
[n_iter
].sym
= NULL
;
4374 ind
[n_iter
].fa
= NULL
;
4376 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4377 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4379 /* Do the actual index interchange. */
4380 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4381 for (i
=1; i
<n_iter
; i
++)
4383 fa
->next
= ind
[i
].fa
;
4388 if (flag_warn_frontend_loop_interchange
)
4390 for (i
=1; i
<n_iter
; i
++)
4392 if (ind
[i
-1].num
> ind
[i
].num
)
4394 gfc_warning (OPT_Wfrontend_loop_interchange
,
4395 "Interchanging loops at %L", &co
->loc
);
4404 #define WALK_SUBEXPR(NODE) \
4407 result = gfc_expr_walker (&(NODE), exprfn, data); \
4412 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4414 /* Walk expression *E, calling EXPRFN on each expression in it. */
4417 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4421 int walk_subtrees
= 1;
4422 gfc_actual_arglist
*a
;
4426 int result
= exprfn (e
, &walk_subtrees
, data
);
4430 switch ((*e
)->expr_type
)
4433 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4434 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4437 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4438 WALK_SUBEXPR (a
->expr
);
4442 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4443 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4444 WALK_SUBEXPR (a
->expr
);
4447 case EXPR_STRUCTURE
:
4449 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4450 c
= gfc_constructor_next (c
))
4452 if (c
->iterator
== NULL
)
4453 WALK_SUBEXPR (c
->expr
);
4457 WALK_SUBEXPR (c
->expr
);
4459 WALK_SUBEXPR (c
->iterator
->var
);
4460 WALK_SUBEXPR (c
->iterator
->start
);
4461 WALK_SUBEXPR (c
->iterator
->end
);
4462 WALK_SUBEXPR (c
->iterator
->step
);
4466 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4469 /* Fall through to the variable case in order to walk the
4473 case EXPR_SUBSTRING
:
4475 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4484 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4486 for (i
=0; i
< ar
->dimen
; i
++)
4488 WALK_SUBEXPR (ar
->start
[i
]);
4489 WALK_SUBEXPR (ar
->end
[i
]);
4490 WALK_SUBEXPR (ar
->stride
[i
]);
4497 WALK_SUBEXPR (r
->u
.ss
.start
);
4498 WALK_SUBEXPR (r
->u
.ss
.end
);
4514 #define WALK_SUBCODE(NODE) \
4517 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4523 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4524 on each expression in it. If any of the hooks returns non-zero, that
4525 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4526 no subcodes or subexpressions are traversed. */
4529 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4532 for (; *c
; c
= &(*c
)->next
)
4534 int walk_subtrees
= 1;
4535 int result
= codefn (c
, &walk_subtrees
, data
);
4542 gfc_actual_arglist
*a
;
4544 gfc_association_list
*alist
;
4545 bool saved_in_omp_workshare
;
4546 bool saved_in_where
;
4548 /* There might be statement insertions before the current code,
4549 which must not affect the expression walker. */
4552 saved_in_omp_workshare
= in_omp_workshare
;
4553 saved_in_where
= in_where
;
4559 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4560 if (co
->ext
.block
.assoc
)
4562 bool saved_in_assoc_list
= in_assoc_list
;
4564 in_assoc_list
= true;
4565 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4566 WALK_SUBEXPR (alist
->target
);
4568 in_assoc_list
= saved_in_assoc_list
;
4575 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4576 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4577 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4578 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4590 case EXEC_ASSIGN_CALL
:
4591 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4592 WALK_SUBEXPR (a
->expr
);
4596 WALK_SUBEXPR (co
->expr1
);
4597 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4598 WALK_SUBEXPR (a
->expr
);
4602 WALK_SUBEXPR (co
->expr1
);
4604 for (b
= co
->block
; b
; b
= b
->block
)
4607 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4609 WALK_SUBEXPR (cp
->low
);
4610 WALK_SUBEXPR (cp
->high
);
4612 WALK_SUBCODE (b
->next
);
4617 case EXEC_DEALLOCATE
:
4620 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4621 WALK_SUBEXPR (a
->expr
);
4626 case EXEC_DO_CONCURRENT
:
4628 gfc_forall_iterator
*fa
;
4629 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4631 WALK_SUBEXPR (fa
->var
);
4632 WALK_SUBEXPR (fa
->start
);
4633 WALK_SUBEXPR (fa
->end
);
4634 WALK_SUBEXPR (fa
->stride
);
4636 if (co
->op
== EXEC_FORALL
)
4642 WALK_SUBEXPR (co
->ext
.open
->unit
);
4643 WALK_SUBEXPR (co
->ext
.open
->file
);
4644 WALK_SUBEXPR (co
->ext
.open
->status
);
4645 WALK_SUBEXPR (co
->ext
.open
->access
);
4646 WALK_SUBEXPR (co
->ext
.open
->form
);
4647 WALK_SUBEXPR (co
->ext
.open
->recl
);
4648 WALK_SUBEXPR (co
->ext
.open
->blank
);
4649 WALK_SUBEXPR (co
->ext
.open
->position
);
4650 WALK_SUBEXPR (co
->ext
.open
->action
);
4651 WALK_SUBEXPR (co
->ext
.open
->delim
);
4652 WALK_SUBEXPR (co
->ext
.open
->pad
);
4653 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4654 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4655 WALK_SUBEXPR (co
->ext
.open
->convert
);
4656 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4657 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4658 WALK_SUBEXPR (co
->ext
.open
->round
);
4659 WALK_SUBEXPR (co
->ext
.open
->sign
);
4660 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4661 WALK_SUBEXPR (co
->ext
.open
->id
);
4662 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4663 WALK_SUBEXPR (co
->ext
.open
->share
);
4664 WALK_SUBEXPR (co
->ext
.open
->cc
);
4668 WALK_SUBEXPR (co
->ext
.close
->unit
);
4669 WALK_SUBEXPR (co
->ext
.close
->status
);
4670 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4671 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4674 case EXEC_BACKSPACE
:
4678 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4679 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4680 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4684 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4685 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4686 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4687 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4688 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4689 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4690 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4691 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4692 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4693 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4694 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4695 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4696 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4697 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4698 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4699 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4700 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4701 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4702 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4703 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4704 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4705 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4706 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4707 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4708 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4709 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4710 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4711 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4712 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4713 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4714 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4715 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4716 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4717 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4718 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4719 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4723 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4724 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4725 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4726 WALK_SUBEXPR (co
->ext
.wait
->id
);
4731 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4732 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4733 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4734 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4735 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4736 WALK_SUBEXPR (co
->ext
.dt
->size
);
4737 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4738 WALK_SUBEXPR (co
->ext
.dt
->id
);
4739 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4740 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4741 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4742 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4743 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4744 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4745 WALK_SUBEXPR (co
->ext
.dt
->round
);
4746 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4747 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4750 case EXEC_OMP_PARALLEL
:
4751 case EXEC_OMP_PARALLEL_DO
:
4752 case EXEC_OMP_PARALLEL_DO_SIMD
:
4753 case EXEC_OMP_PARALLEL_SECTIONS
:
4755 in_omp_workshare
= false;
4757 /* This goto serves as a shortcut to avoid code
4758 duplication or a larger if or switch statement. */
4759 goto check_omp_clauses
;
4761 case EXEC_OMP_WORKSHARE
:
4762 case EXEC_OMP_PARALLEL_WORKSHARE
:
4764 in_omp_workshare
= true;
4768 case EXEC_OMP_CRITICAL
:
4769 case EXEC_OMP_DISTRIBUTE
:
4770 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4771 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4772 case EXEC_OMP_DISTRIBUTE_SIMD
:
4774 case EXEC_OMP_DO_SIMD
:
4775 case EXEC_OMP_ORDERED
:
4776 case EXEC_OMP_SECTIONS
:
4777 case EXEC_OMP_SINGLE
:
4778 case EXEC_OMP_END_SINGLE
:
4780 case EXEC_OMP_TASKLOOP
:
4781 case EXEC_OMP_TASKLOOP_SIMD
:
4782 case EXEC_OMP_TARGET
:
4783 case EXEC_OMP_TARGET_DATA
:
4784 case EXEC_OMP_TARGET_ENTER_DATA
:
4785 case EXEC_OMP_TARGET_EXIT_DATA
:
4786 case EXEC_OMP_TARGET_PARALLEL
:
4787 case EXEC_OMP_TARGET_PARALLEL_DO
:
4788 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4789 case EXEC_OMP_TARGET_SIMD
:
4790 case EXEC_OMP_TARGET_TEAMS
:
4791 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4792 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4793 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4794 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4795 case EXEC_OMP_TARGET_UPDATE
:
4797 case EXEC_OMP_TEAMS
:
4798 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4799 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4800 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4801 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4803 /* Come to this label only from the
4804 EXEC_OMP_PARALLEL_* cases above. */
4808 if (co
->ext
.omp_clauses
)
4810 gfc_omp_namelist
*n
;
4811 static int list_types
[]
4812 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4813 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4815 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4816 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4817 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4818 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4819 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4820 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4821 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4822 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4823 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4824 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4825 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4826 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4827 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4828 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4829 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4830 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4832 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4834 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4836 WALK_SUBEXPR (n
->expr
);
4843 WALK_SUBEXPR (co
->expr1
);
4844 WALK_SUBEXPR (co
->expr2
);
4845 WALK_SUBEXPR (co
->expr3
);
4846 WALK_SUBEXPR (co
->expr4
);
4847 for (b
= co
->block
; b
; b
= b
->block
)
4849 WALK_SUBEXPR (b
->expr1
);
4850 WALK_SUBEXPR (b
->expr2
);
4851 WALK_SUBCODE (b
->next
);
4854 if (co
->op
== EXEC_FORALL
)
4857 if (co
->op
== EXEC_DO
)
4860 if (co
->op
== EXEC_IF
)
4863 if (co
->op
== EXEC_SELECT
)
4866 in_omp_workshare
= saved_in_omp_workshare
;
4867 in_where
= saved_in_where
;