1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2018 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static int call_external_blas (gfc_code
**, int *, void *);
57 static bool has_dimen_vector_ref (gfc_expr
*);
58 static int matmul_temp_args (gfc_code
**, int *,void *data
);
59 static int index_interchange (gfc_code
**, int*, void *);
61 static bool is_fe_temp (gfc_expr
*e
);
64 static void check_locus (gfc_namespace
*);
67 /* How deep we are inside an argument list. */
69 static int count_arglist
;
71 /* Vector of gfc_expr ** we operate on. */
73 static vec
<gfc_expr
**> expr_array
;
75 /* Pointer to the gfc_code we currently work on - to be able to insert
76 a block before the statement. */
78 static gfc_code
**current_code
;
80 /* Pointer to the block to be inserted, and the statement we are
81 changing within the block. */
83 static gfc_code
*inserted_block
, **changed_statement
;
85 /* The namespace we are currently dealing with. */
87 static gfc_namespace
*current_ns
;
89 /* If we are within any forall loop. */
91 static int forall_level
;
93 /* Keep track of whether we are within an OMP workshare. */
95 static bool in_omp_workshare
;
97 /* Keep track of whether we are within a WHERE statement. */
101 /* Keep track of iterators for array constructors. */
103 static int iterator_level
;
105 /* Keep track of DO loop levels. */
113 static vec
<do_t
> doloop_list
;
114 static int doloop_level
;
116 /* Keep track of if and select case levels. */
119 static int select_level
;
121 /* Vector of gfc_expr * to keep track of DO loops. */
123 struct my_struct
*evec
;
125 /* Keep track of association lists. */
127 static bool in_assoc_list
;
129 /* Counter for temporary variables. */
131 static int var_num
= 1;
133 /* What sort of matrix we are dealing with when inlining MATMUL. */
135 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
137 /* Keep track of the number of expressions we have inserted so far
142 /* Entry point - run all passes for a namespace. */
145 gfc_run_passes (gfc_namespace
*ns
)
148 /* Warn about dubious DO loops where the index might
155 doloop_list
.release ();
162 gfc_get_errors (&w
, &e
);
166 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
167 optimize_namespace (ns
);
169 if (flag_frontend_optimize
)
171 optimize_reduction (ns
);
172 if (flag_dump_fortran_optimized
)
173 gfc_dump_parse_tree (ns
, stdout
);
175 expr_array
.release ();
178 if (flag_realloc_lhs
)
179 realloc_strings (ns
);
184 /* Callback function: Warn if there is no location information in a
188 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
189 void *data ATTRIBUTE_UNUSED
)
192 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
193 gfc_warning_internal (0, "No location in statement");
199 /* Callback function: Warn if there is no location information in an
203 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
204 void *data ATTRIBUTE_UNUSED
)
207 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
208 gfc_warning_internal (0, "No location in expression near %L",
209 &((*current_code
)->loc
));
213 /* Run check for missing location information. */
216 check_locus (gfc_namespace
*ns
)
218 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
220 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
222 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
229 /* Callback for each gfc_code node invoked from check_realloc_strings.
230 For an allocatable LHS string which also appears as a variable on
242 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
243 void *data ATTRIBUTE_UNUSED
)
245 gfc_expr
*expr1
, *expr2
;
251 if (co
->op
!= EXEC_ASSIGN
)
255 if (expr1
->ts
.type
!= BT_CHARACTER
256 || !gfc_expr_attr(expr1
).allocatable
257 || !expr1
->ts
.deferred
)
260 if (is_fe_temp (expr1
))
263 expr2
= gfc_discard_nops (co
->expr2
);
265 if (expr2
->expr_type
== EXPR_VARIABLE
)
267 found_substr
= false;
268 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
270 if (ref
->type
== REF_SUBSTRING
)
279 else if (expr2
->expr_type
!= EXPR_ARRAY
280 && (expr2
->expr_type
!= EXPR_OP
281 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
284 if (!gfc_check_dependency (expr1
, expr2
, true))
287 /* gfc_check_dependency doesn't always pick up identical expressions.
288 However, eliminating the above sends the compiler into an infinite
289 loop on valid expressions. Without this check, the gimplifier emits
290 an ICE for a = a, where a is deferred character length. */
291 if (!gfc_dep_compare_expr (expr1
, expr2
))
295 inserted_block
= NULL
;
296 changed_statement
= NULL
;
297 n
= create_var (expr2
, "realloc_string");
302 /* Callback for each gfc_code node invoked through gfc_code_walker
303 from optimize_namespace. */
306 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
307 void *data ATTRIBUTE_UNUSED
)
314 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
315 || op
== EXEC_CALL_PPC
)
321 inserted_block
= NULL
;
322 changed_statement
= NULL
;
324 if (op
== EXEC_ASSIGN
)
325 optimize_assignment (*c
);
329 /* Callback for each gfc_expr node invoked through gfc_code_walker
330 from optimize_namespace. */
333 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
334 void *data ATTRIBUTE_UNUSED
)
338 if ((*e
)->expr_type
== EXPR_FUNCTION
)
341 function_expr
= true;
344 function_expr
= false;
346 if (optimize_trim (*e
))
347 gfc_simplify_expr (*e
, 0);
349 if (optimize_lexical_comparison (*e
))
350 gfc_simplify_expr (*e
, 0);
352 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
353 gfc_simplify_expr (*e
, 0);
355 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
356 switch ((*e
)->value
.function
.isym
->id
)
358 case GFC_ISYM_MINLOC
:
359 case GFC_ISYM_MAXLOC
:
360 optimize_minmaxloc (e
);
372 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
373 function is a scalar, just copy it; otherwise returns the new element, the
374 old one can be freed. */
377 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
379 gfc_expr
*fcn
, *e
= c
->expr
;
381 fcn
= gfc_copy_expr (e
);
384 gfc_constructor_base newbase
;
386 gfc_constructor
*new_c
;
389 new_expr
= gfc_get_expr ();
390 new_expr
->expr_type
= EXPR_ARRAY
;
391 new_expr
->ts
= e
->ts
;
392 new_expr
->where
= e
->where
;
394 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
395 new_c
->iterator
= c
->iterator
;
396 new_expr
->value
.constructor
= newbase
;
404 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
406 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
407 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
408 fn
->value
.function
.isym
->name
,
409 fn
->where
, 3, fcn
, NULL
, NULL
);
410 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
411 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
412 fn
->value
.function
.isym
->name
,
413 fn
->where
, 2, fcn
, NULL
);
415 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
417 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
423 /* Callback function for optimzation of reductions to scalars. Transform ANY
424 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
425 correspondingly. Handly only the simple cases without MASK and DIM. */
428 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
429 void *data ATTRIBUTE_UNUSED
)
434 gfc_actual_arglist
*a
;
435 gfc_actual_arglist
*dim
;
437 gfc_expr
*res
, *new_expr
;
438 gfc_actual_arglist
*mask
;
442 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
443 || fn
->value
.function
.isym
== NULL
)
446 id
= fn
->value
.function
.isym
->id
;
448 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
449 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
452 a
= fn
->value
.function
.actual
;
454 /* Don't handle MASK or DIM. */
458 if (dim
->expr
!= NULL
)
461 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
464 if ( mask
->expr
!= NULL
)
470 if (arg
->expr_type
!= EXPR_ARRAY
)
479 case GFC_ISYM_PRODUCT
:
480 op
= INTRINSIC_TIMES
;
495 c
= gfc_constructor_first (arg
->value
.constructor
);
497 /* Don't do any simplififcation if we have
498 - no element in the constructor or
499 - only have a single element in the array which contains an
505 res
= copy_walk_reduction_arg (c
, fn
);
507 c
= gfc_constructor_next (c
);
510 new_expr
= gfc_get_expr ();
511 new_expr
->ts
= fn
->ts
;
512 new_expr
->expr_type
= EXPR_OP
;
513 new_expr
->rank
= fn
->rank
;
514 new_expr
->where
= fn
->where
;
515 new_expr
->value
.op
.op
= op
;
516 new_expr
->value
.op
.op1
= res
;
517 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
519 c
= gfc_constructor_next (c
);
522 gfc_simplify_expr (res
, 0);
529 /* Callback function for common function elimination, called from cfe_expr_0.
530 Put all eligible function expressions into expr_array. */
533 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
534 void *data ATTRIBUTE_UNUSED
)
537 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
540 /* We don't do character functions with unknown charlens. */
541 if ((*e
)->ts
.type
== BT_CHARACTER
542 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
543 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
546 /* We don't do function elimination within FORALL statements, it can
547 lead to wrong-code in certain circumstances. */
549 if (forall_level
> 0)
552 /* Function elimination inside an iterator could lead to functions which
553 depend on iterator variables being moved outside. FIXME: We should check
554 if the functions do indeed depend on the iterator variable. */
556 if (iterator_level
> 0)
559 /* If we don't know the shape at compile time, we create an allocatable
560 temporary variable to hold the intermediate result, but only if
561 allocation on assignment is active. */
563 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
566 /* Skip the test for pure functions if -faggressive-function-elimination
568 if ((*e
)->value
.function
.esym
)
570 /* Don't create an array temporary for elemental functions. */
571 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
574 /* Only eliminate potentially impure functions if the
575 user specifically requested it. */
576 if (!flag_aggressive_function_elimination
577 && !(*e
)->value
.function
.esym
->attr
.pure
578 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
582 if ((*e
)->value
.function
.isym
)
584 /* Conversions are handled on the fly by the middle end,
585 transpose during trans-* stages and TRANSFER by the middle end. */
586 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
587 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
588 || gfc_inline_intrinsic_function_p (*e
))
591 /* Don't create an array temporary for elemental functions,
592 as this would be wasteful of memory.
593 FIXME: Create a scalar temporary during scalarization. */
594 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
597 if (!(*e
)->value
.function
.isym
->pure
)
601 expr_array
.safe_push (e
);
605 /* Auxiliary function to check if an expression is a temporary created by
609 is_fe_temp (gfc_expr
*e
)
611 if (e
->expr_type
!= EXPR_VARIABLE
)
614 return e
->symtree
->n
.sym
->attr
.fe_temp
;
617 /* Determine the length of a string, if it can be evaluated as a constant
618 expression. Return a newly allocated gfc_expr or NULL on failure.
619 If the user specified a substring which is potentially longer than
620 the string itself, the string will be padded with spaces, which
624 constant_string_length (gfc_expr
*e
)
634 length
= e
->ts
.u
.cl
->length
;
635 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
636 return gfc_copy_expr(length
);
639 /* Return length of substring, if constant. */
640 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
642 if (ref
->type
== REF_SUBSTRING
643 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
645 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
648 mpz_add_ui (res
->value
.integer
, value
, 1);
654 /* Return length of char symbol, if constant. */
656 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
657 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
658 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
659 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
665 /* Insert a block at the current position unless it has already
666 been inserted; in this case use the one already there. */
668 static gfc_namespace
*
673 /* If the block hasn't already been created, do so. */
674 if (inserted_block
== NULL
)
676 inserted_block
= XCNEW (gfc_code
);
677 inserted_block
->op
= EXEC_BLOCK
;
678 inserted_block
->loc
= (*current_code
)->loc
;
679 ns
= gfc_build_block_ns (current_ns
);
680 inserted_block
->ext
.block
.ns
= ns
;
681 inserted_block
->ext
.block
.assoc
= NULL
;
683 ns
->code
= *current_code
;
685 /* If the statement has a label, make sure it is transferred to
686 the newly created block. */
688 if ((*current_code
)->here
)
690 inserted_block
->here
= (*current_code
)->here
;
691 (*current_code
)->here
= NULL
;
694 inserted_block
->next
= (*current_code
)->next
;
695 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
696 (*current_code
)->next
= NULL
;
697 /* Insert the BLOCK at the right position. */
698 *current_code
= inserted_block
;
699 ns
->parent
= current_ns
;
702 ns
= inserted_block
->ext
.block
.ns
;
708 /* Insert a call to the intrinsic len. Use a different name for
709 the symbol tree so we don't run into trouble when the user has
710 renamed len for some reason. */
713 get_len_call (gfc_expr
*str
)
716 gfc_actual_arglist
*actual_arglist
;
718 fcn
= gfc_get_expr ();
719 fcn
->expr_type
= EXPR_FUNCTION
;
720 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN
);
721 actual_arglist
= gfc_get_actual_arglist ();
722 actual_arglist
->expr
= str
;
724 fcn
->value
.function
.actual
= actual_arglist
;
725 fcn
->where
= str
->where
;
726 fcn
->ts
.type
= BT_INTEGER
;
727 fcn
->ts
.kind
= gfc_charlen_int_kind
;
729 gfc_get_sym_tree ("__internal_len", current_ns
, &fcn
->symtree
, false);
730 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
731 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
732 fcn
->symtree
->n
.sym
->attr
.function
= 1;
733 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
734 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
735 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
736 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
742 /* Returns a new expression (a variable) to be used in place of the old one,
743 with an optional assignment statement before the current statement to set
744 the value of the variable. Creates a new BLOCK for the statement if that
745 hasn't already been done and puts the statement, plus the newly created
746 variables, in that block. Special cases: If the expression is constant or
747 a temporary which has already been created, just copy it. */
750 create_var (gfc_expr
* e
, const char *vname
)
752 char name
[GFC_MAX_SYMBOL_LEN
+1];
753 gfc_symtree
*symtree
;
761 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
762 return gfc_copy_expr (e
);
764 /* Creation of an array of unknown size requires realloc on assignment.
765 If that is not possible, just return NULL. */
766 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
769 ns
= insert_block ();
772 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
774 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
776 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
779 symbol
= symtree
->n
.sym
;
784 symbol
->as
= gfc_get_array_spec ();
785 symbol
->as
->rank
= e
->rank
;
787 if (e
->shape
== NULL
)
789 /* We don't know the shape at compile time, so we use an
791 symbol
->as
->type
= AS_DEFERRED
;
792 symbol
->attr
.allocatable
= 1;
796 symbol
->as
->type
= AS_EXPLICIT
;
797 /* Copy the shape. */
798 for (i
=0; i
<e
->rank
; i
++)
802 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
804 mpz_set_si (p
->value
.integer
, 1);
805 symbol
->as
->lower
[i
] = p
;
807 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
809 mpz_set (q
->value
.integer
, e
->shape
[i
]);
810 symbol
->as
->upper
[i
] = q
;
816 if (e
->ts
.type
== BT_CHARACTER
)
820 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
821 length
= constant_string_length (e
);
823 symbol
->ts
.u
.cl
->length
= length
;
824 else if (e
->expr_type
== EXPR_VARIABLE
825 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
826 && e
->ts
.u
.cl
->length
)
827 symbol
->ts
.u
.cl
->length
= get_len_call (gfc_copy_expr (e
));
830 symbol
->attr
.allocatable
= 1;
831 symbol
->ts
.u
.cl
->length
= NULL
;
832 symbol
->ts
.deferred
= 1;
837 symbol
->attr
.flavor
= FL_VARIABLE
;
838 symbol
->attr
.referenced
= 1;
839 symbol
->attr
.dimension
= e
->rank
> 0;
840 symbol
->attr
.fe_temp
= 1;
841 gfc_commit_symbol (symbol
);
843 result
= gfc_get_expr ();
844 result
->expr_type
= EXPR_VARIABLE
;
845 result
->ts
= symbol
->ts
;
846 result
->ts
.deferred
= deferred
;
847 result
->rank
= e
->rank
;
848 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
849 result
->symtree
= symtree
;
850 result
->where
= e
->where
;
853 result
->ref
= gfc_get_ref ();
854 result
->ref
->type
= REF_ARRAY
;
855 result
->ref
->u
.ar
.type
= AR_FULL
;
856 result
->ref
->u
.ar
.where
= e
->where
;
857 result
->ref
->u
.ar
.dimen
= e
->rank
;
858 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
859 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
860 if (warn_array_temporaries
)
861 gfc_warning (OPT_Warray_temporaries
,
862 "Creating array temporary at %L", &(e
->where
));
865 /* Generate the new assignment. */
866 n
= XCNEW (gfc_code
);
868 n
->loc
= (*current_code
)->loc
;
869 n
->next
= *changed_statement
;
870 n
->expr1
= gfc_copy_expr (result
);
872 *changed_statement
= n
;
878 /* Warn about function elimination. */
881 do_warn_function_elimination (gfc_expr
*e
)
884 if (e
->expr_type
== EXPR_FUNCTION
885 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
888 gfc_warning (OPT_Wfunction_elimination
,
889 "Removing call to impure function %qs at %L", name
,
892 gfc_warning (OPT_Wfunction_elimination
,
893 "Removing call to impure function at %L",
899 /* Callback function for the code walker for doing common function
900 elimination. This builds up the list of functions in the expression
901 and goes through them to detect duplicates, which it then replaces
905 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
906 void *data ATTRIBUTE_UNUSED
)
912 /* Don't do this optimization within OMP workshare or ASSOC lists. */
914 if (in_omp_workshare
|| in_assoc_list
)
920 expr_array
.release ();
922 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
924 /* Walk through all the functions. */
926 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
928 /* Skip if the function has been replaced by a variable already. */
929 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
936 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
939 newvar
= create_var (*ei
, "fcn");
941 if (warn_function_elimination
)
942 do_warn_function_elimination (*ej
);
945 *ej
= gfc_copy_expr (newvar
);
952 /* We did all the necessary walking in this function. */
957 /* Callback function for common function elimination, called from
958 gfc_code_walker. This keeps track of the current code, in order
959 to insert statements as needed. */
962 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
965 inserted_block
= NULL
;
966 changed_statement
= NULL
;
968 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
969 and allocation on assigment are prohibited inside WHERE, and finally
970 masking an expression would lead to wrong-code when replacing
973 b = sum(foo(a) + foo(a))
984 if ((*c
)->op
== EXEC_WHERE
)
994 /* Dummy function for expression call back, for use when we
995 really don't want to do any walking. */
998 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
999 void *data ATTRIBUTE_UNUSED
)
1005 /* Dummy function for code callback, for use when we really
1006 don't want to do anything. */
1008 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
1009 int *walk_subtrees ATTRIBUTE_UNUSED
,
1010 void *data ATTRIBUTE_UNUSED
)
1015 /* Code callback function for converting
1022 This is because common function elimination would otherwise place the
1023 temporary variables outside the loop. */
1026 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1027 void *data ATTRIBUTE_UNUSED
)
1030 gfc_code
*c_if1
, *c_if2
, *c_exit
;
1031 gfc_code
*loopblock
;
1032 gfc_expr
*e_not
, *e_cond
;
1034 if (co
->op
!= EXEC_DO_WHILE
)
1037 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1042 /* Generate the condition of the if statement, which is .not. the original
1044 e_not
= gfc_get_expr ();
1045 e_not
->ts
= e_cond
->ts
;
1046 e_not
->where
= e_cond
->where
;
1047 e_not
->expr_type
= EXPR_OP
;
1048 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1049 e_not
->value
.op
.op1
= e_cond
;
1051 /* Generate the EXIT statement. */
1052 c_exit
= XCNEW (gfc_code
);
1053 c_exit
->op
= EXEC_EXIT
;
1054 c_exit
->ext
.which_construct
= co
;
1055 c_exit
->loc
= co
->loc
;
1057 /* Generate the IF statement. */
1058 c_if2
= XCNEW (gfc_code
);
1059 c_if2
->op
= EXEC_IF
;
1060 c_if2
->expr1
= e_not
;
1061 c_if2
->next
= c_exit
;
1062 c_if2
->loc
= co
->loc
;
1064 /* ... plus the one to chain it to. */
1065 c_if1
= XCNEW (gfc_code
);
1066 c_if1
->op
= EXEC_IF
;
1067 c_if1
->block
= c_if2
;
1068 c_if1
->loc
= co
->loc
;
1070 /* Make the DO WHILE loop into a DO block by replacing the condition
1071 with a true constant. */
1072 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1074 /* Hang the generated if statement into the loop body. */
1076 loopblock
= co
->block
->next
;
1077 co
->block
->next
= c_if1
;
1078 c_if1
->next
= loopblock
;
1083 /* Code callback function for converting
1096 because otherwise common function elimination would place the BLOCKs
1097 into the wrong place. */
1100 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1101 void *data ATTRIBUTE_UNUSED
)
1104 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1106 if (co
->op
!= EXEC_IF
)
1109 /* This loop starts out with the first ELSE statement. */
1110 else_stmt
= co
->block
->block
;
1112 while (else_stmt
!= NULL
)
1114 gfc_code
*next_else
;
1116 /* If there is no condition, we're done. */
1117 if (else_stmt
->expr1
== NULL
)
1120 next_else
= else_stmt
->block
;
1122 /* Generate the new IF statement. */
1123 c_if2
= XCNEW (gfc_code
);
1124 c_if2
->op
= EXEC_IF
;
1125 c_if2
->expr1
= else_stmt
->expr1
;
1126 c_if2
->next
= else_stmt
->next
;
1127 c_if2
->loc
= else_stmt
->loc
;
1128 c_if2
->block
= next_else
;
1130 /* ... plus the one to chain it to. */
1131 c_if1
= XCNEW (gfc_code
);
1132 c_if1
->op
= EXEC_IF
;
1133 c_if1
->block
= c_if2
;
1134 c_if1
->loc
= else_stmt
->loc
;
1136 /* Insert the new IF after the ELSE. */
1137 else_stmt
->expr1
= NULL
;
1138 else_stmt
->next
= c_if1
;
1139 else_stmt
->block
= NULL
;
1141 else_stmt
= next_else
;
1143 /* Don't walk subtrees. */
1147 /* Callback function to var_in_expr - return true if expr1 and
1148 expr2 are identical variables. */
1150 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1153 gfc_expr
*expr1
= (gfc_expr
*) data
;
1154 gfc_expr
*expr2
= *e
;
1156 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1159 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1162 /* Return true if expr1 is found in expr2. */
1165 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1167 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1169 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1174 struct do_stack
*prev
;
1179 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1180 optimize by replacing do loops with their analog array slices. For
1183 write (*,*) (a(i), i=1,4)
1187 write (*,*) a(1:4:1) . */
1190 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1193 gfc_expr
*new_e
, *expr
, *start
;
1195 struct do_stack ds_push
;
1196 int i
, future_rank
= 0;
1197 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1200 /* Find the first transfer/do statement. */
1201 for (curr
= code
; curr
; curr
= curr
->next
)
1203 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1207 /* Ensure it is the only transfer/do statement because cases like
1209 write (*,*) (a(i), b(i), i=1,4)
1211 cannot be optimized. */
1213 if (!curr
|| curr
->next
)
1216 if (curr
->op
== EXEC_DO
)
1218 if (curr
->ext
.iterator
->var
->ref
)
1220 ds_push
.prev
= stack_top
;
1221 ds_push
.iter
= curr
->ext
.iterator
;
1222 ds_push
.code
= curr
;
1223 stack_top
= &ds_push
;
1224 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1226 if (curr
!= stack_top
->code
&& !*has_reached
)
1228 curr
->block
->next
= NULL
;
1229 gfc_free_statements (curr
);
1232 *has_reached
= true;
1238 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1242 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1245 /* Find the iterators belonging to each variable and check conditions. */
1246 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1248 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1249 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1252 start
= ref
->u
.ar
.start
[i
];
1253 gfc_simplify_expr (start
, 0);
1254 switch (start
->expr_type
)
1258 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1262 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1263 if (!stack_top
|| !stack_top
->iter
1264 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1266 /* Check for (a(i,i), i=1,3). */
1270 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1277 iters
[i
] = stack_top
->iter
;
1278 stack_top
= stack_top
->prev
;
1286 switch (start
->value
.op
.op
)
1288 case INTRINSIC_PLUS
:
1289 case INTRINSIC_TIMES
:
1290 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1291 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1293 case INTRINSIC_MINUS
:
1294 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1295 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1296 || start
->value
.op
.op1
->ref
)
1298 if (!stack_top
|| !stack_top
->iter
1299 || stack_top
->iter
->var
->symtree
1300 != start
->value
.op
.op1
->symtree
)
1302 iters
[i
] = stack_top
->iter
;
1303 stack_top
= stack_top
->prev
;
1315 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1316 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1320 gfc_expr
*var
= iters
[i
]->var
;
1321 for (int j
= i
- 1; j
< i
; j
++)
1324 && (var_in_expr (var
, iters
[j
]->start
)
1325 || var_in_expr (var
, iters
[j
]->end
)
1326 || var_in_expr (var
, iters
[j
]->step
)))
1332 /* Create new expr. */
1333 new_e
= gfc_copy_expr (curr
->expr1
);
1334 new_e
->expr_type
= EXPR_VARIABLE
;
1335 new_e
->rank
= future_rank
;
1336 if (curr
->expr1
->shape
)
1337 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1339 /* Assign new starts, ends and strides if necessary. */
1340 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1344 start
= ref
->u
.ar
.start
[i
];
1345 switch (start
->expr_type
)
1348 gfc_internal_error ("bad expression");
1351 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1352 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1353 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1354 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1355 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1356 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1359 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1360 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1361 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1362 expr
= gfc_copy_expr (start
);
1363 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1364 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1365 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1366 expr
= gfc_copy_expr (start
);
1367 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1368 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1369 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1370 switch (start
->value
.op
.op
)
1372 case INTRINSIC_MINUS
:
1373 case INTRINSIC_PLUS
:
1374 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1376 case INTRINSIC_TIMES
:
1377 expr
= gfc_copy_expr (start
);
1378 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1379 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1380 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1383 gfc_internal_error ("bad op");
1387 gfc_internal_error ("bad expression");
1390 curr
->expr1
= new_e
;
1392 /* Insert modified statement. Check whether the statement needs to be
1393 inserted at the lowest level. */
1394 if (!stack_top
->iter
)
1398 curr
->next
= prev
->next
->next
;
1403 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1404 stack_top
->code
->block
->next
= curr
;
1408 stack_top
->code
->block
->next
= curr
;
1412 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1413 tries to optimize its block. */
1416 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1417 void *data ATTRIBUTE_UNUSED
)
1419 gfc_code
**curr
, *prev
= NULL
;
1420 struct do_stack write
, first
;
1424 || ((*code
)->block
->op
!= EXEC_WRITE
1425 && (*code
)->block
->op
!= EXEC_READ
))
1433 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1435 if ((*curr
)->op
== EXEC_DO
)
1437 first
.prev
= &write
;
1438 first
.iter
= (*curr
)->ext
.iterator
;
1441 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1449 /* Optimize a namespace, including all contained namespaces.
1450 flag_frontend_optimize and flag_fronend_loop_interchange are
1451 handled separately. */
1454 optimize_namespace (gfc_namespace
*ns
)
1456 gfc_namespace
*saved_ns
= gfc_current_ns
;
1458 gfc_current_ns
= ns
;
1461 in_assoc_list
= false;
1462 in_omp_workshare
= false;
1464 if (flag_frontend_optimize
)
1466 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1467 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1468 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1469 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1470 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1471 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1477 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1482 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1486 if (flag_external_blas
)
1487 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1490 if (flag_inline_matmul_limit
!= 0)
1491 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1495 if (flag_frontend_loop_interchange
)
1496 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1499 /* BLOCKs are handled in the expression walker below. */
1500 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1502 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1503 optimize_namespace (ns
);
1505 gfc_current_ns
= saved_ns
;
1508 /* Handle dependencies for allocatable strings which potentially redefine
1509 themselves in an assignment. */
1512 realloc_strings (gfc_namespace
*ns
)
1515 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1517 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1519 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1520 realloc_strings (ns
);
1526 optimize_reduction (gfc_namespace
*ns
)
1529 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1530 callback_reduction
, NULL
);
1532 /* BLOCKs are handled in the expression walker below. */
1533 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1535 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1536 optimize_reduction (ns
);
1540 /* Replace code like
1543 a = matmul(b,c) ; a = a + d
1544 where the array function is not elemental and not allocatable
1545 and does not depend on the left-hand side.
1549 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1557 if (e
->expr_type
== EXPR_OP
)
1559 switch (e
->value
.op
.op
)
1561 /* Unary operators and exponentiation: Only look at a single
1564 case INTRINSIC_UPLUS
:
1565 case INTRINSIC_UMINUS
:
1566 case INTRINSIC_PARENTHESES
:
1567 case INTRINSIC_POWER
:
1568 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1572 case INTRINSIC_CONCAT
:
1573 /* Do not do string concatenations. */
1577 /* Binary operators. */
1578 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1581 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1587 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1588 && ! (e
->value
.function
.esym
1589 && (e
->value
.function
.esym
->attr
.elemental
1590 || e
->value
.function
.esym
->attr
.allocatable
1591 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1592 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1593 && ! (e
->value
.function
.isym
1594 && (e
->value
.function
.isym
->elemental
1595 || e
->ts
.type
!= c
->expr1
->ts
.type
1596 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1597 && ! gfc_inline_intrinsic_function_p (e
))
1603 /* Insert a new assignment statement after the current one. */
1604 n
= XCNEW (gfc_code
);
1605 n
->op
= EXEC_ASSIGN
;
1610 n
->expr1
= gfc_copy_expr (c
->expr1
);
1611 n
->expr2
= c
->expr2
;
1612 new_expr
= gfc_copy_expr (c
->expr1
);
1620 /* Nothing to optimize. */
1624 /* Remove unneeded TRIMs at the end of expressions. */
1627 remove_trim (gfc_expr
*rhs
)
1635 /* Check for a // b // trim(c). Looping is probably not
1636 necessary because the parser usually generates
1637 (// (// a b ) trim(c) ) , but better safe than sorry. */
1639 while (rhs
->expr_type
== EXPR_OP
1640 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1641 rhs
= rhs
->value
.op
.op2
;
1643 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1644 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1646 strip_function_call (rhs
);
1647 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1655 /* Optimizations for an assignment. */
1658 optimize_assignment (gfc_code
* c
)
1660 gfc_expr
*lhs
, *rhs
;
1665 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1667 /* Optimize a = trim(b) to a = b. */
1670 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1671 if (is_empty_string (rhs
))
1672 rhs
->value
.character
.length
= 0;
1675 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1676 optimize_binop_array_assignment (c
, &rhs
, false);
1680 /* Remove an unneeded function call, modifying the expression.
1681 This replaces the function call with the value of its
1682 first argument. The rest of the argument list is freed. */
1685 strip_function_call (gfc_expr
*e
)
1688 gfc_actual_arglist
*a
;
1690 a
= e
->value
.function
.actual
;
1692 /* We should have at least one argument. */
1693 gcc_assert (a
->expr
!= NULL
);
1697 /* Free the remaining arglist, if any. */
1699 gfc_free_actual_arglist (a
->next
);
1701 /* Graft the argument expression onto the original function. */
1707 /* Optimization of lexical comparison functions. */
1710 optimize_lexical_comparison (gfc_expr
*e
)
1712 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1715 switch (e
->value
.function
.isym
->id
)
1718 return optimize_comparison (e
, INTRINSIC_LE
);
1721 return optimize_comparison (e
, INTRINSIC_GE
);
1724 return optimize_comparison (e
, INTRINSIC_GT
);
1727 return optimize_comparison (e
, INTRINSIC_LT
);
1735 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1736 do CHARACTER because of possible pessimization involving character
1740 combine_array_constructor (gfc_expr
*e
)
1743 gfc_expr
*op1
, *op2
;
1746 gfc_constructor
*c
, *new_c
;
1747 gfc_constructor_base oldbase
, newbase
;
1752 /* Array constructors have rank one. */
1756 /* Don't try to combine association lists, this makes no sense
1757 and leads to an ICE. */
1761 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1762 if (forall_level
> 0)
1765 /* Inside an iterator, things can get hairy; we are likely to create
1766 an invalid temporary variable. */
1767 if (iterator_level
> 0)
1770 op1
= e
->value
.op
.op1
;
1771 op2
= e
->value
.op
.op2
;
1776 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1777 scalar_first
= false;
1778 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1780 scalar_first
= true;
1781 op1
= e
->value
.op
.op2
;
1782 op2
= e
->value
.op
.op1
;
1787 if (op2
->ts
.type
== BT_CHARACTER
)
1790 /* This might be an expanded constructor with very many constant values. If
1791 we perform the operation here, we might end up with a long compile time
1792 and actually longer execution time, so a length bound is in order here.
1793 If the constructor constains something which is not a constant, it did
1794 not come from an expansion, so leave it alone. */
1796 #define CONSTR_LEN_MAX 4
1798 oldbase
= op1
->value
.constructor
;
1802 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1804 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1812 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1815 #undef CONSTR_LEN_MAX
1818 e
->expr_type
= EXPR_ARRAY
;
1820 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1822 for (c
= gfc_constructor_first (oldbase
); c
;
1823 c
= gfc_constructor_next (c
))
1825 new_expr
= gfc_get_expr ();
1826 new_expr
->ts
= e
->ts
;
1827 new_expr
->expr_type
= EXPR_OP
;
1828 new_expr
->rank
= c
->expr
->rank
;
1829 new_expr
->where
= c
->expr
->where
;
1830 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1834 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1835 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1839 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1840 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1843 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1844 new_c
->iterator
= c
->iterator
;
1848 gfc_free_expr (op1
);
1849 gfc_free_expr (op2
);
1850 gfc_free_expr (scalar
);
1852 e
->value
.constructor
= newbase
;
1856 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1857 2**k into ishift(1,k) */
1860 optimize_power (gfc_expr
*e
)
1862 gfc_expr
*op1
, *op2
;
1863 gfc_expr
*iand
, *ishft
;
1865 if (e
->ts
.type
!= BT_INTEGER
)
1868 op1
= e
->value
.op
.op1
;
1870 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1873 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1875 gfc_free_expr (op1
);
1877 op2
= e
->value
.op
.op2
;
1882 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1883 "_internal_iand", e
->where
, 2, op2
,
1884 gfc_get_int_expr (e
->ts
.kind
,
1887 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1888 "_internal_ishft", e
->where
, 2, iand
,
1889 gfc_get_int_expr (e
->ts
.kind
,
1892 e
->value
.op
.op
= INTRINSIC_MINUS
;
1893 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1894 e
->value
.op
.op2
= ishft
;
1897 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1899 gfc_free_expr (op1
);
1901 op2
= e
->value
.op
.op2
;
1905 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1906 "_internal_ishft", e
->where
, 2,
1907 gfc_get_int_expr (e
->ts
.kind
,
1914 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1916 op2
= e
->value
.op
.op2
;
1920 gfc_free_expr (op1
);
1921 gfc_free_expr (op2
);
1923 e
->expr_type
= EXPR_CONSTANT
;
1924 e
->value
.op
.op1
= NULL
;
1925 e
->value
.op
.op2
= NULL
;
1926 mpz_init_set_si (e
->value
.integer
, 1);
1927 /* Typespec and location are still OK. */
1934 /* Recursive optimization of operators. */
1937 optimize_op (gfc_expr
*e
)
1941 gfc_intrinsic_op op
= e
->value
.op
.op
;
1945 /* Only use new-style comparisons. */
1948 case INTRINSIC_EQ_OS
:
1952 case INTRINSIC_GE_OS
:
1956 case INTRINSIC_LE_OS
:
1960 case INTRINSIC_NE_OS
:
1964 case INTRINSIC_GT_OS
:
1968 case INTRINSIC_LT_OS
:
1984 changed
= optimize_comparison (e
, op
);
1987 /* Look at array constructors. */
1988 case INTRINSIC_PLUS
:
1989 case INTRINSIC_MINUS
:
1990 case INTRINSIC_TIMES
:
1991 case INTRINSIC_DIVIDE
:
1992 return combine_array_constructor (e
) || changed
;
1994 case INTRINSIC_POWER
:
1995 return optimize_power (e
);
2005 /* Return true if a constant string contains only blanks. */
2008 is_empty_string (gfc_expr
*e
)
2012 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
2015 for (i
=0; i
< e
->value
.character
.length
; i
++)
2017 if (e
->value
.character
.string
[i
] != ' ')
2025 /* Insert a call to the intrinsic len_trim. Use a different name for
2026 the symbol tree so we don't run into trouble when the user has
2027 renamed len_trim for some reason. */
2030 get_len_trim_call (gfc_expr
*str
, int kind
)
2033 gfc_actual_arglist
*actual_arglist
, *next
;
2035 fcn
= gfc_get_expr ();
2036 fcn
->expr_type
= EXPR_FUNCTION
;
2037 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
2038 actual_arglist
= gfc_get_actual_arglist ();
2039 actual_arglist
->expr
= str
;
2040 next
= gfc_get_actual_arglist ();
2041 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
2042 actual_arglist
->next
= next
;
2044 fcn
->value
.function
.actual
= actual_arglist
;
2045 fcn
->where
= str
->where
;
2046 fcn
->ts
.type
= BT_INTEGER
;
2047 fcn
->ts
.kind
= gfc_charlen_int_kind
;
2049 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
2050 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
2051 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
2052 fcn
->symtree
->n
.sym
->attr
.function
= 1;
2053 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
2054 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
2055 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
2056 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
2062 /* Optimize expressions for equality. */
2065 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
2067 gfc_expr
*op1
, *op2
;
2071 gfc_actual_arglist
*firstarg
, *secondarg
;
2073 if (e
->expr_type
== EXPR_OP
)
2077 op1
= e
->value
.op
.op1
;
2078 op2
= e
->value
.op
.op2
;
2080 else if (e
->expr_type
== EXPR_FUNCTION
)
2082 /* One of the lexical comparison functions. */
2083 firstarg
= e
->value
.function
.actual
;
2084 secondarg
= firstarg
->next
;
2085 op1
= firstarg
->expr
;
2086 op2
= secondarg
->expr
;
2091 /* Strip off unneeded TRIM calls from string comparisons. */
2093 change
= remove_trim (op1
);
2095 if (remove_trim (op2
))
2098 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2099 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2100 handles them well). However, there are also cases that need a non-scalar
2101 argument. For example the any intrinsic. See PR 45380. */
2105 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2107 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2108 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2110 bool empty_op1
, empty_op2
;
2111 empty_op1
= is_empty_string (op1
);
2112 empty_op2
= is_empty_string (op2
);
2114 if (empty_op1
|| empty_op2
)
2120 /* This can only happen when an error for comparing
2121 characters of different kinds has already been issued. */
2122 if (empty_op1
&& empty_op2
)
2125 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2126 str
= empty_op1
? op2
: op1
;
2128 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2132 gfc_free_expr (op1
);
2134 gfc_free_expr (op2
);
2138 e
->value
.op
.op1
= fcn
;
2139 e
->value
.op
.op2
= zero
;
2144 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2146 if (flag_finite_math_only
2147 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2148 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2150 eq
= gfc_dep_compare_expr (op1
, op2
);
2153 /* Replace A // B < A // C with B < C, and A // B < C // B
2155 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2156 && op1
->expr_type
== EXPR_OP
2157 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2158 && op2
->expr_type
== EXPR_OP
2159 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2161 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2162 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2163 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2164 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2166 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2168 /* Watch out for 'A ' // x vs. 'A' // x. */
2170 if (op1_left
->expr_type
== EXPR_CONSTANT
2171 && op2_left
->expr_type
== EXPR_CONSTANT
2172 && op1_left
->value
.character
.length
2173 != op2_left
->value
.character
.length
)
2181 firstarg
->expr
= op1_right
;
2182 secondarg
->expr
= op2_right
;
2186 e
->value
.op
.op1
= op1_right
;
2187 e
->value
.op
.op2
= op2_right
;
2189 optimize_comparison (e
, op
);
2193 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2199 firstarg
->expr
= op1_left
;
2200 secondarg
->expr
= op2_left
;
2204 e
->value
.op
.op1
= op1_left
;
2205 e
->value
.op
.op2
= op2_left
;
2208 optimize_comparison (e
, op
);
2215 /* eq can only be -1, 0 or 1 at this point. */
2243 gfc_internal_error ("illegal OP in optimize_comparison");
2247 /* Replace the expression by a constant expression. The typespec
2248 and where remains the way it is. */
2251 e
->expr_type
= EXPR_CONSTANT
;
2252 e
->value
.logical
= result
;
2260 /* Optimize a trim function by replacing it with an equivalent substring
2261 involving a call to len_trim. This only works for expressions where
2262 variables are trimmed. Return true if anything was modified. */
2265 optimize_trim (gfc_expr
*e
)
2270 gfc_ref
**rr
= NULL
;
2272 /* Don't do this optimization within an argument list, because
2273 otherwise aliasing issues may occur. */
2275 if (count_arglist
!= 1)
2278 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2279 || e
->value
.function
.isym
== NULL
2280 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2283 a
= e
->value
.function
.actual
->expr
;
2285 if (a
->expr_type
!= EXPR_VARIABLE
)
2288 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2290 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2293 /* Follow all references to find the correct place to put the newly
2294 created reference. FIXME: Also handle substring references and
2295 array references. Array references cause strange regressions at
2300 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2302 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2307 strip_function_call (e
);
2312 /* Create the reference. */
2314 ref
= gfc_get_ref ();
2315 ref
->type
= REF_SUBSTRING
;
2317 /* Set the start of the reference. */
2319 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2321 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2323 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2325 /* Set the end of the reference to the call to len_trim. */
2327 ref
->u
.ss
.end
= fcn
;
2328 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2333 /* Optimize minloc(b), where b is rank 1 array, into
2334 (/ minloc(b, dim=1) /), and similarly for maxloc,
2335 as the latter forms are expanded inline. */
2338 optimize_minmaxloc (gfc_expr
**e
)
2341 gfc_actual_arglist
*a
;
2345 || fn
->value
.function
.actual
== NULL
2346 || fn
->value
.function
.actual
->expr
== NULL
2347 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2350 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2351 (*e
)->shape
= fn
->shape
;
2354 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2356 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2357 strcpy (name
, fn
->value
.function
.name
);
2358 p
= strstr (name
, "loc0");
2360 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2361 if (fn
->value
.function
.actual
->next
)
2363 a
= fn
->value
.function
.actual
->next
;
2364 gcc_assert (a
->expr
== NULL
);
2368 a
= gfc_get_actual_arglist ();
2369 fn
->value
.function
.actual
->next
= a
;
2371 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2373 mpz_set_ui (a
->expr
->value
.integer
, 1);
2376 /* Callback function for code checking that we do not pass a DO variable to an
2377 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2380 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2381 void *data ATTRIBUTE_UNUSED
)
2385 gfc_formal_arglist
*f
;
2386 gfc_actual_arglist
*a
;
2393 /* If the doloop_list grew, we have to truncate it here. */
2395 if ((unsigned) doloop_level
< doloop_list
.length())
2396 doloop_list
.truncate (doloop_level
);
2403 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2408 loop
.branch_level
= if_level
+ select_level
;
2409 loop
.seen_goto
= false;
2410 doloop_list
.safe_push (loop
);
2413 /* If anything could transfer control away from a suspicious
2414 subscript, make sure to set seen_goto in the current DO loop
2419 case EXEC_ERROR_STOP
:
2425 if (co
->ext
.open
->err
)
2430 if (co
->ext
.close
->err
)
2434 case EXEC_BACKSPACE
:
2439 if (co
->ext
.filepos
->err
)
2444 if (co
->ext
.filepos
->err
)
2450 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2455 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2456 loop
.seen_goto
= true;
2461 if (co
->resolved_sym
== NULL
)
2464 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2466 /* Withot a formal arglist, there is only unknown INTENT,
2467 which we don't check for. */
2475 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2483 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2485 if (a
->expr
&& a
->expr
->symtree
2486 && a
->expr
->symtree
->n
.sym
== do_sym
)
2488 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2489 gfc_error_now ("Variable %qs at %L set to undefined "
2490 "value inside loop beginning at %L as "
2491 "INTENT(OUT) argument to subroutine %qs",
2492 do_sym
->name
, &a
->expr
->where
,
2493 &(doloop_list
[i
].c
->loc
),
2494 co
->symtree
->n
.sym
->name
);
2495 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2496 gfc_error_now ("Variable %qs at %L not definable inside "
2497 "loop beginning at %L as INTENT(INOUT) "
2498 "argument to subroutine %qs",
2499 do_sym
->name
, &a
->expr
->where
,
2500 &(doloop_list
[i
].c
->loc
),
2501 co
->symtree
->n
.sym
->name
);
2512 if (seen_goto
&& doloop_level
> 0)
2513 doloop_list
[doloop_level
-1].seen_goto
= true;
2518 /* Callback function to warn about different things within DO loops. */
2521 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2522 void *data ATTRIBUTE_UNUSED
)
2526 if (doloop_list
.length () == 0)
2529 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2532 last
= &doloop_list
.last();
2533 if (last
->seen_goto
&& !warn_do_subscript
)
2536 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2548 /* Callback function - if the expression is the variable in data->sym,
2549 replace it with a constant from data->val. */
2552 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2559 if (ex
->expr_type
!= EXPR_VARIABLE
)
2562 d
= (insert_index_t
*) data
;
2563 if (ex
->symtree
->n
.sym
!= d
->sym
)
2566 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2567 mpz_set (n
->value
.integer
, d
->val
);
2574 /* In the expression e, replace occurrences of the variable sym with
2575 val. If this results in a constant expression, return true and
2576 return the value in ret. Return false if the expression already
2577 is a constant. Caller has to clear ret in that case. */
2580 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2583 insert_index_t data
;
2586 if (e
->expr_type
== EXPR_CONSTANT
)
2589 n
= gfc_copy_expr (e
);
2591 mpz_init_set (data
.val
, val
);
2592 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2593 gfc_simplify_expr (n
, 0);
2595 if (n
->expr_type
== EXPR_CONSTANT
)
2598 mpz_init_set (ret
, n
->value
.integer
);
2603 mpz_clear (data
.val
);
2609 /* Check array subscripts for possible out-of-bounds accesses in DO
2610 loops with constant bounds. */
2613 do_subscript (gfc_expr
**e
)
2623 /* Constants are already checked. */
2624 if (v
->expr_type
== EXPR_CONSTANT
)
2627 /* Wrong warnings will be generated in an associate list. */
2631 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2633 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2636 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2639 mpz_t do_start
, do_step
, do_end
;
2640 bool have_do_start
, have_do_end
;
2641 bool error_not_proven
;
2648 /* If we are within a branch, or a goto or equivalent
2649 was seen in the DO loop before, then we cannot prove that
2650 this expression is actually evaluated. Don't do anything
2651 unless we want to see it all. */
2652 error_not_proven
= lp
->seen_goto
2653 || lp
->branch_level
< if_level
+ select_level
;
2655 if (error_not_proven
&& !warn_do_subscript
)
2658 if (error_not_proven
)
2659 warn
= OPT_Wdo_subscript
;
2663 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2664 if (do_sym
->ts
.type
!= BT_INTEGER
)
2667 /* If we do not know about the stepsize, the loop may be zero trip.
2668 Do not warn in this case. */
2670 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2671 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2675 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2677 have_do_start
= true;
2678 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2681 have_do_start
= false;
2684 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2687 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2690 have_do_end
= false;
2692 if (!have_do_start
&& !have_do_end
)
2695 /* May have to correct the end value if the step does not equal
2697 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2703 mpz_sub (diff
, do_end
, do_start
);
2704 mpz_tdiv_r (rem
, diff
, do_step
);
2705 mpz_sub (do_end
, do_end
, rem
);
2710 for (i
= 0; i
< ar
->dimen
; i
++)
2713 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2714 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2716 if (ar
->as
->lower
[i
]
2717 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2718 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2719 gfc_warning (warn
, "Array reference at %L out of bounds "
2720 "(%ld < %ld) in loop beginning at %L",
2721 &ar
->start
[i
]->where
, mpz_get_si (val
),
2722 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2723 &doloop_list
[j
].c
->loc
);
2725 if (ar
->as
->upper
[i
]
2726 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2727 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2728 gfc_warning (warn
, "Array reference at %L out of bounds "
2729 "(%ld > %ld) in loop beginning at %L",
2730 &ar
->start
[i
]->where
, mpz_get_si (val
),
2731 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2732 &doloop_list
[j
].c
->loc
);
2737 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2738 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2740 if (ar
->as
->lower
[i
]
2741 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2742 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2743 gfc_warning (warn
, "Array reference at %L out of bounds "
2744 "(%ld < %ld) in loop beginning at %L",
2745 &ar
->start
[i
]->where
, mpz_get_si (val
),
2746 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2747 &doloop_list
[j
].c
->loc
);
2749 if (ar
->as
->upper
[i
]
2750 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2751 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2752 gfc_warning (warn
, "Array reference at %L out of bounds "
2753 "(%ld > %ld) in loop beginning at %L",
2754 &ar
->start
[i
]->where
, mpz_get_si (val
),
2755 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2756 &doloop_list
[j
].c
->loc
);
2766 /* Function for functions checking that we do not pass a DO variable
2767 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2770 do_intent (gfc_expr
**e
)
2772 gfc_formal_arglist
*f
;
2773 gfc_actual_arglist
*a
;
2780 if (expr
->expr_type
!= EXPR_FUNCTION
)
2783 /* Intrinsic functions don't modify their arguments. */
2785 if (expr
->value
.function
.isym
)
2788 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2790 /* Without a formal arglist, there is only unknown INTENT,
2791 which we don't check for. */
2795 a
= expr
->value
.function
.actual
;
2799 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2806 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2808 if (a
->expr
&& a
->expr
->symtree
2809 && a
->expr
->symtree
->n
.sym
== do_sym
)
2811 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2812 gfc_error_now ("Variable %qs at %L set to undefined value "
2813 "inside loop beginning at %L as INTENT(OUT) "
2814 "argument to function %qs", do_sym
->name
,
2815 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2816 expr
->symtree
->n
.sym
->name
);
2817 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2818 gfc_error_now ("Variable %qs at %L not definable inside loop"
2819 " beginning at %L as INTENT(INOUT) argument to"
2820 " function %qs", do_sym
->name
,
2821 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2822 expr
->symtree
->n
.sym
->name
);
2833 doloop_warn (gfc_namespace
*ns
)
2835 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2838 /* This selction deals with inlining calls to MATMUL. */
2840 /* Replace calls to matmul outside of straight assignments with a temporary
2841 variable so that later inlining will work. */
2844 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2848 bool *found
= (bool *) data
;
2852 if (e
->expr_type
!= EXPR_FUNCTION
2853 || e
->value
.function
.isym
== NULL
2854 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2857 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2858 || in_where
|| in_assoc_list
)
2861 /* Check if this is already in the form c = matmul(a,b). */
2863 if ((*current_code
)->expr2
== e
)
2866 n
= create_var (e
, "matmul");
2868 /* If create_var is unable to create a variable (for example if
2869 -fno-realloc-lhs is in force with a variable that does not have bounds
2870 known at compile-time), just return. */
2880 /* Set current_code and associated variables so that matmul_to_var_expr can
2884 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2885 void *data ATTRIBUTE_UNUSED
)
2887 if (current_code
!= c
)
2890 inserted_block
= NULL
;
2891 changed_statement
= NULL
;
2898 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2899 for a and b if there is a dependency between the arguments and the
2900 result variable or if a or b are the result of calculations that cannot
2901 be handled by the inliner. */
2904 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2905 void *data ATTRIBUTE_UNUSED
)
2907 gfc_expr
*expr1
, *expr2
;
2909 gfc_actual_arglist
*a
, *b
;
2911 gfc_expr
*matrix_a
, *matrix_b
;
2912 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2916 if (co
->op
!= EXEC_ASSIGN
)
2919 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2923 /* This has some duplication with inline_matmul_assign. This
2924 is because the creation of temporary variables could still fail,
2925 and inline_matmul_assign still needs to be able to handle these
2930 if (expr2
->expr_type
!= EXPR_FUNCTION
2931 || expr2
->value
.function
.isym
== NULL
2932 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2936 a
= expr2
->value
.function
.actual
;
2937 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2938 if (matrix_a
!= NULL
)
2940 if (matrix_a
->expr_type
== EXPR_VARIABLE
2941 && (gfc_check_dependency (matrix_a
, expr1
, true)
2942 || has_dimen_vector_ref (matrix_a
)))
2950 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2951 if (matrix_b
!= NULL
)
2953 if (matrix_b
->expr_type
== EXPR_VARIABLE
2954 && (gfc_check_dependency (matrix_b
, expr1
, true)
2955 || has_dimen_vector_ref (matrix_b
)))
2961 if (!a_tmp
&& !b_tmp
)
2965 inserted_block
= NULL
;
2966 changed_statement
= NULL
;
2970 at
= create_var (a
->expr
,"mma");
2977 bt
= create_var (b
->expr
,"mmb");
2984 /* Auxiliary function to build and simplify an array inquiry function.
2985 dim is zero-based. */
2988 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
2991 gfc_expr
*dim_arg
, *kind
;
2997 case GFC_ISYM_LBOUND
:
2998 name
= "_gfortran_lbound";
3001 case GFC_ISYM_UBOUND
:
3002 name
= "_gfortran_ubound";
3006 name
= "_gfortran_size";
3013 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
3015 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3018 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3019 gfc_index_integer_kind
);
3021 ec
= gfc_copy_expr (e
);
3023 /* No bounds checking, this will be done before the loops if -fcheck=bounds
3025 ec
->no_bounds_check
= 1;
3026 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
3028 gfc_simplify_expr (fcn
, 0);
3029 fcn
->no_bounds_check
= 1;
3033 /* Builds a logical expression. */
3036 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3041 ts
.type
= BT_LOGICAL
;
3042 ts
.kind
= gfc_default_logical_kind
;
3043 res
= gfc_get_expr ();
3044 res
->where
= e1
->where
;
3045 res
->expr_type
= EXPR_OP
;
3046 res
->value
.op
.op
= op
;
3047 res
->value
.op
.op1
= e1
;
3048 res
->value
.op
.op2
= e2
;
3055 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3056 compatible typespecs. */
3059 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3063 res
= gfc_get_expr ();
3065 res
->where
= e1
->where
;
3066 res
->expr_type
= EXPR_OP
;
3067 res
->value
.op
.op
= op
;
3068 res
->value
.op
.op1
= e1
;
3069 res
->value
.op
.op2
= e2
;
3070 gfc_simplify_expr (res
, 0);
3074 /* Generate the IF statement for a runtime check if we want to do inlining or
3075 not - putting in the code for both branches and putting it into the syntax
3076 tree is the caller's responsibility. For fixed array sizes, this should be
3077 removed by DCE. Only called for rank-two matrices A and B. */
3080 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3082 gfc_expr
*inline_limit
;
3083 gfc_code
*if_1
, *if_2
, *else_2
;
3084 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3088 /* Calculation is done in real to avoid integer overflow. */
3090 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3092 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3093 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3096 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3097 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3098 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3102 ts
.kind
= gfc_default_real_kind
;
3103 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3104 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3105 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3107 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3108 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3110 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3111 gfc_simplify_expr (cond
, 0);
3113 else_2
= XCNEW (gfc_code
);
3114 else_2
->op
= EXEC_IF
;
3115 else_2
->loc
= a
->where
;
3117 if_2
= XCNEW (gfc_code
);
3120 if_2
->loc
= a
->where
;
3121 if_2
->block
= else_2
;
3123 if_1
= XCNEW (gfc_code
);
3126 if_1
->loc
= a
->where
;
3132 /* Insert code to issue a runtime error if the expressions are not equal. */
3135 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3138 gfc_code
*if_1
, *if_2
;
3140 gfc_actual_arglist
*a1
, *a2
, *a3
;
3142 gcc_assert (e1
->where
.lb
);
3143 /* Build the call to runtime_error. */
3144 c
= XCNEW (gfc_code
);
3148 /* Get a null-terminated message string. */
3150 a1
= gfc_get_actual_arglist ();
3151 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3152 msg
, strlen(msg
)+1);
3155 /* Pass the value of the first expression. */
3156 a2
= gfc_get_actual_arglist ();
3157 a2
->expr
= gfc_copy_expr (e1
);
3160 /* Pass the value of the second expression. */
3161 a3
= gfc_get_actual_arglist ();
3162 a3
->expr
= gfc_copy_expr (e2
);
3165 gfc_check_fe_runtime_error (c
->ext
.actual
);
3166 gfc_resolve_fe_runtime_error (c
);
3168 if_2
= XCNEW (gfc_code
);
3170 if_2
->loc
= e1
->where
;
3173 if_1
= XCNEW (gfc_code
);
3176 if_1
->loc
= e1
->where
;
3178 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3179 gfc_simplify_expr (cond
, 0);
3185 /* Handle matrix reallocation. Caller is responsible to insert into
3188 For the two-dimensional case, build
3190 if (allocated(c)) then
3191 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3193 allocate (c(size(a,1), size(b,2)))
3196 allocate (c(size(a,1),size(b,2)))
3199 and for the other cases correspondingly.
3203 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3204 enum matrix_case m_case
)
3207 gfc_expr
*allocated
, *alloc_expr
;
3208 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3209 gfc_code
*else_alloc
;
3210 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3212 gfc_expr
*cond
, *ne1
, *ne2
;
3214 if (warn_realloc_lhs
)
3215 gfc_warning (OPT_Wrealloc_lhs
,
3216 "Code for reallocating the allocatable array at %L will "
3217 "be added", &c
->where
);
3219 alloc_expr
= gfc_copy_expr (c
);
3221 ar
= gfc_find_array_ref (alloc_expr
);
3222 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3224 /* c comes in as a full ref. Change it into a copy and make it into an
3225 element ref so it has the right form for for ALLOCATE. In the same
3226 switch statement, also generate the size comparison for the secod IF
3229 ar
->type
= AR_ELEMENT
;
3234 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3235 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3236 ne1
= build_logical_expr (INTRINSIC_NE
,
3237 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3238 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3239 ne2
= build_logical_expr (INTRINSIC_NE
,
3240 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3241 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3242 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3246 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3247 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3249 ne1
= build_logical_expr (INTRINSIC_NE
,
3250 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3251 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3252 ne2
= build_logical_expr (INTRINSIC_NE
,
3253 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3254 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3255 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3260 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3261 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3263 ne1
= build_logical_expr (INTRINSIC_NE
,
3264 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3265 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3266 ne2
= build_logical_expr (INTRINSIC_NE
,
3267 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3268 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3269 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3273 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3274 cond
= build_logical_expr (INTRINSIC_NE
,
3275 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3276 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3280 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3281 cond
= build_logical_expr (INTRINSIC_NE
,
3282 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3283 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3287 /* This can only happen for BLAS, we do not handle that case in
3289 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3290 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3292 ne1
= build_logical_expr (INTRINSIC_NE
,
3293 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3294 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3295 ne2
= build_logical_expr (INTRINSIC_NE
,
3296 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3297 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3299 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3307 gfc_simplify_expr (cond
, 0);
3309 /* We need two identical allocate statements in two
3310 branches of the IF statement. */
3312 allocate1
= XCNEW (gfc_code
);
3313 allocate1
->op
= EXEC_ALLOCATE
;
3314 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3315 allocate1
->loc
= c
->where
;
3316 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3318 allocate_else
= XCNEW (gfc_code
);
3319 allocate_else
->op
= EXEC_ALLOCATE
;
3320 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3321 allocate_else
->loc
= c
->where
;
3322 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3324 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3325 "_gfortran_allocated", c
->where
,
3326 1, gfc_copy_expr (c
));
3328 deallocate
= XCNEW (gfc_code
);
3329 deallocate
->op
= EXEC_DEALLOCATE
;
3330 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3331 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3332 deallocate
->next
= allocate1
;
3333 deallocate
->loc
= c
->where
;
3335 if_size_2
= XCNEW (gfc_code
);
3336 if_size_2
->op
= EXEC_IF
;
3337 if_size_2
->expr1
= cond
;
3338 if_size_2
->loc
= c
->where
;
3339 if_size_2
->next
= deallocate
;
3341 if_size_1
= XCNEW (gfc_code
);
3342 if_size_1
->op
= EXEC_IF
;
3343 if_size_1
->block
= if_size_2
;
3344 if_size_1
->loc
= c
->where
;
3346 else_alloc
= XCNEW (gfc_code
);
3347 else_alloc
->op
= EXEC_IF
;
3348 else_alloc
->loc
= c
->where
;
3349 else_alloc
->next
= allocate_else
;
3351 if_alloc_2
= XCNEW (gfc_code
);
3352 if_alloc_2
->op
= EXEC_IF
;
3353 if_alloc_2
->expr1
= allocated
;
3354 if_alloc_2
->loc
= c
->where
;
3355 if_alloc_2
->next
= if_size_1
;
3356 if_alloc_2
->block
= else_alloc
;
3358 if_alloc_1
= XCNEW (gfc_code
);
3359 if_alloc_1
->op
= EXEC_IF
;
3360 if_alloc_1
->block
= if_alloc_2
;
3361 if_alloc_1
->loc
= c
->where
;
3366 /* Callback function for has_function_or_op. */
3369 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3370 void *data ATTRIBUTE_UNUSED
)
3375 return (*e
)->expr_type
== EXPR_FUNCTION
3376 || (*e
)->expr_type
== EXPR_OP
;
3379 /* Returns true if the expression contains a function. */
3382 has_function_or_op (gfc_expr
**e
)
3387 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3390 /* Freeze (assign to a temporary variable) a single expression. */
3393 freeze_expr (gfc_expr
**ep
)
3396 if (has_function_or_op (ep
))
3398 ne
= create_var (*ep
, "freeze");
3403 /* Go through an expression's references and assign them to temporary
3404 variables if they contain functions. This is usually done prior to
3405 front-end scalarization to avoid multiple invocations of functions. */
3408 freeze_references (gfc_expr
*e
)
3414 for (r
=e
->ref
; r
; r
=r
->next
)
3416 if (r
->type
== REF_SUBSTRING
)
3418 if (r
->u
.ss
.start
!= NULL
)
3419 freeze_expr (&r
->u
.ss
.start
);
3421 if (r
->u
.ss
.end
!= NULL
)
3422 freeze_expr (&r
->u
.ss
.end
);
3424 else if (r
->type
== REF_ARRAY
)
3433 for (i
=0; i
<ar
->dimen
; i
++)
3435 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3437 freeze_expr (&ar
->start
[i
]);
3438 freeze_expr (&ar
->end
[i
]);
3439 freeze_expr (&ar
->stride
[i
]);
3441 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3443 freeze_expr (&ar
->start
[i
]);
3449 for (i
=0; i
<ar
->dimen
; i
++)
3450 freeze_expr (&ar
->start
[i
]);
3460 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3463 convert_to_index_kind (gfc_expr
*e
)
3467 gcc_assert (e
!= NULL
);
3469 res
= gfc_copy_expr (e
);
3471 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3473 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3477 ts
.type
= BT_INTEGER
;
3478 ts
.kind
= gfc_index_integer_kind
;
3480 gfc_convert_type_warn (e
, &ts
, 2, 0);
3486 /* Function to create a DO loop including creation of the
3487 iteration variable. gfc_expr are copied.*/
3490 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3491 gfc_namespace
*ns
, char *vname
)
3494 char name
[GFC_MAX_SYMBOL_LEN
+1];
3495 gfc_symtree
*symtree
;
3500 /* Create an expression for the iteration variable. */
3502 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3504 sprintf (name
, "__var_%d_do", var_num
++);
3507 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3510 /* Create the loop variable. */
3512 symbol
= symtree
->n
.sym
;
3513 symbol
->ts
.type
= BT_INTEGER
;
3514 symbol
->ts
.kind
= gfc_index_integer_kind
;
3515 symbol
->attr
.flavor
= FL_VARIABLE
;
3516 symbol
->attr
.referenced
= 1;
3517 symbol
->attr
.dimension
= 0;
3518 symbol
->attr
.fe_temp
= 1;
3519 gfc_commit_symbol (symbol
);
3521 i
= gfc_get_expr ();
3522 i
->expr_type
= EXPR_VARIABLE
;
3526 i
->symtree
= symtree
;
3528 /* ... and the nested DO statements. */
3529 n
= XCNEW (gfc_code
);
3532 n
->ext
.iterator
= gfc_get_iterator ();
3533 n
->ext
.iterator
->var
= i
;
3534 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3535 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3537 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3539 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3542 n2
= XCNEW (gfc_code
);
3550 /* Get the upper bound of the DO loops for matmul along a dimension. This
3554 get_size_m1 (gfc_expr
*e
, int dimen
)
3559 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3561 res
= gfc_get_constant_expr (BT_INTEGER
,
3562 gfc_index_integer_kind
, &e
->where
);
3563 mpz_sub_ui (res
->value
.integer
, size
, 1);
3568 res
= get_operand (INTRINSIC_MINUS
,
3569 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3570 gfc_get_int_expr (gfc_index_integer_kind
,
3572 gfc_simplify_expr (res
, 0);
3578 /* Function to return a scalarized expression. It is assumed that indices are
3579 zero based to make generation of DO loops easier. A zero as index will
3580 access the first element along a dimension. Single element references will
3581 be skipped. A NULL as an expression will be replaced by a full reference.
3582 This assumes that the index loops have gfc_index_integer_kind, and that all
3583 references have been frozen. */
3586 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3595 e
= gfc_copy_expr(e_in
);
3599 ar
= gfc_find_array_ref (e
);
3601 /* We scalarize count_index variables, reducing the rank by count_index. */
3603 e
->rank
= rank
- count_index
;
3605 was_fullref
= ar
->type
== AR_FULL
;
3608 ar
->type
= AR_ELEMENT
;
3610 ar
->type
= AR_SECTION
;
3612 /* Loop over the indices. For each index, create the expression
3613 index * stride + lbound(e, dim). */
3616 for (i
=0; i
< ar
->dimen
; i
++)
3618 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3620 if (index
[i_index
] != NULL
)
3622 gfc_expr
*lbound
, *nindex
;
3625 loopvar
= gfc_copy_expr (index
[i_index
]);
3631 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3632 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3636 ts
.type
= BT_INTEGER
;
3637 ts
.kind
= gfc_index_integer_kind
;
3638 gfc_convert_type (tmp
, &ts
, 2);
3640 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3645 /* Calculate the lower bound of the expression. */
3648 lbound
= gfc_copy_expr (ar
->start
[i
]);
3649 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3653 ts
.type
= BT_INTEGER
;
3654 ts
.kind
= gfc_index_integer_kind
;
3655 gfc_convert_type (lbound
, &ts
, 2);
3664 lbound_e
= gfc_copy_expr (e_in
);
3666 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3667 if (ref
->type
== REF_ARRAY
3668 && (ref
->u
.ar
.type
== AR_FULL
3669 || ref
->u
.ar
.type
== AR_SECTION
))
3674 gfc_free_ref_list (ref
->next
);
3680 /* Look at full individual sections, like a(:). The first index
3681 is the lbound of a full ref. */
3688 /* For assumed size, we need to keep around the final
3689 reference in order not to get an error on resolution
3690 below, and we cannot use AR_FULL. */
3692 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3694 ar
->type
= AR_SECTION
;
3703 for (j
= 0; j
< to
; j
++)
3705 gfc_free_expr (ar
->start
[j
]);
3706 ar
->start
[j
] = NULL
;
3707 gfc_free_expr (ar
->end
[j
]);
3709 gfc_free_expr (ar
->stride
[j
]);
3710 ar
->stride
[j
] = NULL
;
3713 /* We have to get rid of the shape, if there is one. Do
3714 so by freeing it and calling gfc_resolve to rebuild
3715 it, if necessary. */
3717 if (lbound_e
->shape
)
3718 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3720 lbound_e
->rank
= ar
->dimen
;
3721 gfc_resolve_expr (lbound_e
);
3723 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3725 gfc_free_expr (lbound_e
);
3728 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3730 gfc_free_expr (ar
->start
[i
]);
3731 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3733 gfc_free_expr (ar
->end
[i
]);
3735 gfc_free_expr (ar
->stride
[i
]);
3736 ar
->stride
[i
] = NULL
;
3737 gfc_simplify_expr (ar
->start
[i
], 0);
3739 else if (was_fullref
)
3741 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3747 /* Bounds checking will be done before the loops if -fcheck=bounds
3749 e
->no_bounds_check
= 1;
3753 /* Helper function to check for a dimen vector as subscript. */
3756 has_dimen_vector_ref (gfc_expr
*e
)
3761 ar
= gfc_find_array_ref (e
);
3763 if (ar
->type
== AR_FULL
)
3766 for (i
=0; i
<ar
->dimen
; i
++)
3767 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3773 /* If handed an expression of the form
3777 check if A can be handled by matmul and return if there is an uneven number
3778 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3779 otherwise. The caller has to check for the correct rank. */
3782 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3789 if (e
->expr_type
== EXPR_VARIABLE
)
3791 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3794 else if (e
->expr_type
== EXPR_FUNCTION
)
3796 if (e
->value
.function
.isym
== NULL
)
3799 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3801 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3802 *transpose
= !*transpose
;
3808 e
= e
->value
.function
.actual
->expr
;
3815 /* Macros for unified error messages. */
3817 #define B_ERROR(n) _("Incorrect extent in argument B in MATMUL intrinsic in " \
3818 "dimension " #n ": is %ld, should be %ld")
3820 #define C_ERROR(n) _("Array bound mismatch for dimension " #n " of array " \
3824 /* Inline assignments of the form c = matmul(a,b).
3825 Handle only the cases currently where b and c are rank-two arrays.
3827 This basically translates the code to
3833 do k=0, size(a, 2)-1
3834 do i=0, size(a, 1)-1
3835 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3836 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3837 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3838 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3847 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3848 void *data ATTRIBUTE_UNUSED
)
3851 gfc_expr
*expr1
, *expr2
;
3852 gfc_expr
*matrix_a
, *matrix_b
;
3853 gfc_actual_arglist
*a
, *b
;
3854 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3856 gfc_expr
*u1
, *u2
, *u3
;
3858 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3860 gfc_expr
*var_1
, *var_2
, *var_3
;
3863 gfc_intrinsic_op op_times
, op_plus
;
3864 enum matrix_case m_case
;
3866 gfc_code
*if_limit
= NULL
;
3867 gfc_code
**next_code_point
;
3868 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3871 if (co
->op
!= EXEC_ASSIGN
)
3874 if (in_where
|| in_assoc_list
)
3877 /* The BLOCKS generated for the temporary variables and FORALL don't
3879 if (forall_level
> 0)
3882 /* For now don't do anything in OpenMP workshare, it confuses
3883 its translation, which expects only the allowed statements in there.
3884 We should figure out how to parallelize this eventually. */
3885 if (in_omp_workshare
)
3890 if (expr2
->expr_type
!= EXPR_FUNCTION
3891 || expr2
->value
.function
.isym
== NULL
3892 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3896 inserted_block
= NULL
;
3897 changed_statement
= NULL
;
3899 a
= expr2
->value
.function
.actual
;
3900 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3901 if (matrix_a
== NULL
)
3905 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3906 if (matrix_b
== NULL
)
3909 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3910 || has_dimen_vector_ref (matrix_b
))
3913 /* We do not handle data dependencies yet. */
3914 if (gfc_check_dependency (expr1
, matrix_a
, true)
3915 || gfc_check_dependency (expr1
, matrix_b
, true))
3919 if (matrix_a
->rank
== 2)
3923 if (matrix_b
->rank
== 2 && !transpose_b
)
3928 if (matrix_b
->rank
== 1)
3930 else /* matrix_b->rank == 2 */
3939 else /* matrix_a->rank == 1 */
3941 if (matrix_b
->rank
== 2)
3951 ns
= insert_block ();
3953 /* Assign the type of the zero expression for initializing the resulting
3954 array, and the expression (+ and * for real, integer and complex;
3955 .and. and .or for logical. */
3957 switch(expr1
->ts
.type
)
3960 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3961 op_times
= INTRINSIC_TIMES
;
3962 op_plus
= INTRINSIC_PLUS
;
3966 op_times
= INTRINSIC_AND
;
3967 op_plus
= INTRINSIC_OR
;
3968 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3972 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3974 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3975 op_times
= INTRINSIC_TIMES
;
3976 op_plus
= INTRINSIC_PLUS
;
3980 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3982 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3983 op_times
= INTRINSIC_TIMES
;
3984 op_plus
= INTRINSIC_PLUS
;
3992 current_code
= &ns
->code
;
3994 /* Freeze the references, keeping track of how many temporary variables were
3997 freeze_references (matrix_a
);
3998 freeze_references (matrix_b
);
3999 freeze_references (expr1
);
4002 next_code_point
= current_code
;
4005 next_code_point
= &ns
->code
;
4006 for (i
=0; i
<n_vars
; i
++)
4007 next_code_point
= &(*next_code_point
)->next
;
4010 /* Take care of the inline flag. If the limit check evaluates to a
4011 constant, dead code elimination will eliminate the unneeded branch. */
4013 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
4014 && matrix_b
->rank
== 2)
4016 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
4017 flag_inline_matmul_limit
);
4019 /* Insert the original statement into the else branch. */
4020 if_limit
->block
->block
->next
= co
;
4023 /* ... and the new ones go into the original one. */
4024 *next_code_point
= if_limit
;
4025 next_code_point
= &if_limit
->block
->next
;
4028 zero_e
->no_bounds_check
= 1;
4030 assign_zero
= XCNEW (gfc_code
);
4031 assign_zero
->op
= EXEC_ASSIGN
;
4032 assign_zero
->loc
= co
->loc
;
4033 assign_zero
->expr1
= gfc_copy_expr (expr1
);
4034 assign_zero
->expr1
->no_bounds_check
= 1;
4035 assign_zero
->expr2
= zero_e
;
4037 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4039 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4042 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
4048 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4049 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4050 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4051 *next_code_point
= test
;
4052 next_code_point
= &test
->next
;
4056 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4057 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4058 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4059 *next_code_point
= test
;
4060 next_code_point
= &test
->next
;
4066 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4067 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4068 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4069 *next_code_point
= test
;
4070 next_code_point
= &test
->next
;
4074 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4075 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4076 test
= runtime_error_ne (c1
, b2
, C_ERROR(1));
4077 *next_code_point
= test
;
4078 next_code_point
= &test
->next
;
4084 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4085 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4086 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4087 *next_code_point
= test
;
4088 next_code_point
= &test
->next
;
4092 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4093 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4094 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4095 *next_code_point
= test
;
4096 next_code_point
= &test
->next
;
4098 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4099 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4100 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4101 *next_code_point
= test
;
4102 next_code_point
= &test
->next
;
4108 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4109 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4110 /* matrix_b is transposed, hence dimension 1 for the error message. */
4111 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4112 *next_code_point
= test
;
4113 next_code_point
= &test
->next
;
4117 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4118 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4119 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4120 *next_code_point
= test
;
4121 next_code_point
= &test
->next
;
4123 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4124 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4125 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4126 *next_code_point
= test
;
4127 next_code_point
= &test
->next
;
4133 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4134 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4135 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4136 *next_code_point
= test
;
4137 next_code_point
= &test
->next
;
4141 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4142 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4143 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4144 *next_code_point
= test
;
4145 next_code_point
= &test
->next
;
4147 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4148 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4149 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4150 *next_code_point
= test
;
4151 next_code_point
= &test
->next
;
4160 /* Handle the reallocation, if needed. */
4164 gfc_code
*lhs_alloc
;
4166 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4168 *next_code_point
= lhs_alloc
;
4169 next_code_point
= &lhs_alloc
->next
;
4173 *next_code_point
= assign_zero
;
4175 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4177 assign_matmul
= XCNEW (gfc_code
);
4178 assign_matmul
->op
= EXEC_ASSIGN
;
4179 assign_matmul
->loc
= co
->loc
;
4181 /* Get the bounds for the loops, create them and create the scalarized
4188 u1
= get_size_m1 (matrix_b
, 2);
4189 u2
= get_size_m1 (matrix_a
, 2);
4190 u3
= get_size_m1 (matrix_a
, 1);
4192 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4193 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4194 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4196 do_1
->block
->next
= do_2
;
4197 do_2
->block
->next
= do_3
;
4198 do_3
->block
->next
= assign_matmul
;
4200 var_1
= do_1
->ext
.iterator
->var
;
4201 var_2
= do_2
->ext
.iterator
->var
;
4202 var_3
= do_3
->ext
.iterator
->var
;
4206 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4210 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4214 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4220 u1
= get_size_m1 (matrix_b
, 1);
4221 u2
= get_size_m1 (matrix_a
, 2);
4222 u3
= get_size_m1 (matrix_a
, 1);
4224 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4225 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4226 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4228 do_1
->block
->next
= do_2
;
4229 do_2
->block
->next
= do_3
;
4230 do_3
->block
->next
= assign_matmul
;
4232 var_1
= do_1
->ext
.iterator
->var
;
4233 var_2
= do_2
->ext
.iterator
->var
;
4234 var_3
= do_3
->ext
.iterator
->var
;
4238 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4242 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4246 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4252 u1
= get_size_m1 (matrix_a
, 2);
4253 u2
= get_size_m1 (matrix_b
, 2);
4254 u3
= get_size_m1 (matrix_a
, 1);
4256 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4257 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4258 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4260 do_1
->block
->next
= do_2
;
4261 do_2
->block
->next
= do_3
;
4262 do_3
->block
->next
= assign_matmul
;
4264 var_1
= do_1
->ext
.iterator
->var
;
4265 var_2
= do_2
->ext
.iterator
->var
;
4266 var_3
= do_3
->ext
.iterator
->var
;
4270 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4274 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4278 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4283 u1
= get_size_m1 (matrix_b
, 1);
4284 u2
= get_size_m1 (matrix_a
, 1);
4286 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4287 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4289 do_1
->block
->next
= do_2
;
4290 do_2
->block
->next
= assign_matmul
;
4292 var_1
= do_1
->ext
.iterator
->var
;
4293 var_2
= do_2
->ext
.iterator
->var
;
4296 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4300 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4303 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4308 u1
= get_size_m1 (matrix_b
, 2);
4309 u2
= get_size_m1 (matrix_a
, 1);
4311 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4312 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4314 do_1
->block
->next
= do_2
;
4315 do_2
->block
->next
= assign_matmul
;
4317 var_1
= do_1
->ext
.iterator
->var
;
4318 var_2
= do_2
->ext
.iterator
->var
;
4321 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4324 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4328 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4336 /* Build the conjg call around the variables. Set the typespec manually
4337 because gfc_build_intrinsic_call sometimes gets this wrong. */
4342 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4343 matrix_a
->where
, 1, ascalar
);
4351 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4352 matrix_b
->where
, 1, bscalar
);
4355 /* First loop comes after the zero assignment. */
4356 assign_zero
->next
= do_1
;
4358 /* Build the assignment expression in the loop. */
4359 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4361 mult
= get_operand (op_times
, ascalar
, bscalar
);
4362 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4364 /* If we don't want to keep the original statement around in
4365 the else branch, we can free it. */
4367 if (if_limit
== NULL
)
4368 gfc_free_statements(co
);
4372 gfc_free_expr (zero
);
4377 /* Change matmul function calls in the form of
4381 to the corresponding call to a BLAS routine, if applicable. */
4384 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4385 void *data ATTRIBUTE_UNUSED
)
4387 gfc_code
*co
, *co_next
;
4388 gfc_expr
*expr1
, *expr2
;
4389 gfc_expr
*matrix_a
, *matrix_b
;
4390 gfc_code
*if_limit
= NULL
;
4391 gfc_actual_arglist
*a
, *b
;
4392 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4394 const char *blas_name
;
4395 const char *transa
, *transb
;
4396 gfc_expr
*c1
, *c2
, *b1
;
4397 gfc_actual_arglist
*actual
, *next
;
4400 enum matrix_case m_case
;
4402 gfc_code
**next_code_point
;
4404 /* Many of the tests for inline matmul also apply here. */
4408 if (co
->op
!= EXEC_ASSIGN
)
4411 if (in_where
|| in_assoc_list
)
4414 /* The BLOCKS generated for the temporary variables and FORALL don't
4416 if (forall_level
> 0)
4419 /* For now don't do anything in OpenMP workshare, it confuses
4420 its translation, which expects only the allowed statements in there. */
4422 if (in_omp_workshare
)
4427 if (expr2
->expr_type
!= EXPR_FUNCTION
4428 || expr2
->value
.function
.isym
== NULL
4429 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4432 type
= expr2
->ts
.type
;
4433 kind
= expr2
->ts
.kind
;
4435 /* Guard against recursion. */
4437 if (expr2
->external_blas
)
4440 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4443 if (type
== BT_REAL
)
4446 blas_name
= "sgemm";
4448 blas_name
= "dgemm";
4452 else if (type
== BT_COMPLEX
)
4455 blas_name
= "cgemm";
4457 blas_name
= "zgemm";
4464 a
= expr2
->value
.function
.actual
;
4465 if (a
->expr
->rank
!= 2)
4469 if (b
->expr
->rank
!= 2)
4472 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4473 if (matrix_a
== NULL
)
4486 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4487 if (matrix_b
== NULL
)
4516 inserted_block
= NULL
;
4517 changed_statement
= NULL
;
4519 expr2
->external_blas
= 1;
4521 /* We do not handle data dependencies yet. */
4522 if (gfc_check_dependency (expr1
, matrix_a
, true)
4523 || gfc_check_dependency (expr1
, matrix_b
, true))
4526 /* Generate the if statement and hang it into the tree. */
4527 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4529 (*current_code
) = if_limit
;
4531 if_limit
->block
->next
= co
;
4533 call
= XCNEW (gfc_code
);
4534 call
->loc
= co
->loc
;
4536 /* Bounds checking - a bit simpler than for inlining since we only
4537 have to take care of two-dimensional arrays here. */
4539 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4540 next_code_point
= &(if_limit
->block
->block
->next
);
4542 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4545 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4546 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4550 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4551 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4552 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4553 *next_code_point
= test
;
4554 next_code_point
= &test
->next
;
4558 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4559 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4560 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4561 *next_code_point
= test
;
4562 next_code_point
= &test
->next
;
4564 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4565 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4566 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4567 *next_code_point
= test
;
4568 next_code_point
= &test
->next
;
4574 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4575 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4576 /* matrix_b is transposed, hence dimension 1 for the error message. */
4577 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4578 *next_code_point
= test
;
4579 next_code_point
= &test
->next
;
4583 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4584 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4585 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4586 *next_code_point
= test
;
4587 next_code_point
= &test
->next
;
4589 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4590 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4591 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4592 *next_code_point
= test
;
4593 next_code_point
= &test
->next
;
4599 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4600 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4601 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4602 *next_code_point
= test
;
4603 next_code_point
= &test
->next
;
4607 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4608 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4609 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4610 *next_code_point
= test
;
4611 next_code_point
= &test
->next
;
4613 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4614 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4615 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4616 *next_code_point
= test
;
4617 next_code_point
= &test
->next
;
4622 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4623 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4624 test
= runtime_error_ne (b2
, a1
, B_ERROR(1));
4625 *next_code_point
= test
;
4626 next_code_point
= &test
->next
;
4630 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4631 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4632 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4633 *next_code_point
= test
;
4634 next_code_point
= &test
->next
;
4636 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4637 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4638 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4639 *next_code_point
= test
;
4640 next_code_point
= &test
->next
;
4649 /* Handle the reallocation, if needed. */
4653 gfc_code
*lhs_alloc
;
4655 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4656 *next_code_point
= lhs_alloc
;
4657 next_code_point
= &lhs_alloc
->next
;
4660 *next_code_point
= call
;
4661 if_limit
->next
= co_next
;
4663 /* Set up the BLAS call. */
4665 call
->op
= EXEC_CALL
;
4667 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4668 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4669 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4670 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4671 call
->resolved_sym
= call
->symtree
->n
.sym
;
4673 /* Argument TRANSA. */
4674 next
= gfc_get_actual_arglist ();
4675 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4678 call
->ext
.actual
= next
;
4680 /* Argument TRANSB. */
4682 next
= gfc_get_actual_arglist ();
4683 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4685 actual
->next
= next
;
4687 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4688 gfc_integer_4_kind
);
4689 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4690 gfc_integer_4_kind
);
4692 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4693 gfc_integer_4_kind
);
4697 next
= gfc_get_actual_arglist ();
4699 actual
->next
= next
;
4703 next
= gfc_get_actual_arglist ();
4705 actual
->next
= next
;
4709 next
= gfc_get_actual_arglist ();
4711 actual
->next
= next
;
4713 /* Argument ALPHA - set to one. */
4715 next
= gfc_get_actual_arglist ();
4716 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4717 if (type
== BT_REAL
)
4718 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4720 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4721 actual
->next
= next
;
4725 next
= gfc_get_actual_arglist ();
4726 next
->expr
= gfc_copy_expr (matrix_a
);
4727 actual
->next
= next
;
4731 next
= gfc_get_actual_arglist ();
4732 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4733 1, gfc_integer_4_kind
);
4734 actual
->next
= next
;
4738 next
= gfc_get_actual_arglist ();
4739 next
->expr
= gfc_copy_expr (matrix_b
);
4740 actual
->next
= next
;
4744 next
= gfc_get_actual_arglist ();
4745 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4746 1, gfc_integer_4_kind
);
4747 actual
->next
= next
;
4749 /* Argument BETA - set to zero. */
4751 next
= gfc_get_actual_arglist ();
4752 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4753 if (type
== BT_REAL
)
4754 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4756 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4757 actual
->next
= next
;
4762 next
= gfc_get_actual_arglist ();
4763 next
->expr
= gfc_copy_expr (expr1
);
4764 actual
->next
= next
;
4768 next
= gfc_get_actual_arglist ();
4769 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4770 1, gfc_integer_4_kind
);
4771 actual
->next
= next
;
4777 /* Code for index interchange for loops which are grouped together in DO
4778 CONCURRENT or FORALL statements. This is currently only applied if the
4779 iterations are grouped together in a single statement.
4781 For this transformation, it is assumed that memory access in strides is
4782 expensive, and that loops which access later indices (which access memory
4783 in bigger strides) should be moved to the first loops.
4785 For this, a loop over all the statements is executed, counting the times
4786 that the loop iteration values are accessed in each index. The loop
4787 indices are then sorted to minimize access to later indices from inner
4790 /* Type for holding index information. */
4794 gfc_forall_iterator
*fa
;
4796 int n
[GFC_MAX_DIMENSIONS
];
4799 /* Callback function to determine if an expression is the
4800 corresponding variable. */
4803 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4805 gfc_expr
*expr
= *e
;
4808 if (expr
->expr_type
!= EXPR_VARIABLE
)
4811 sym
= (gfc_symbol
*) data
;
4812 return sym
== expr
->symtree
->n
.sym
;
4815 /* Callback function to calculate the cost of a certain index. */
4818 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4828 if (expr
->expr_type
!= EXPR_VARIABLE
)
4832 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4834 if (ref
->type
== REF_ARRAY
)
4840 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4843 ind
= (ind_type
*) data
;
4844 for (i
= 0; i
< ar
->dimen
; i
++)
4846 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4848 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4855 /* Callback function for qsort, to sort the loop indices. */
4858 loop_comp (const void *e1
, const void *e2
)
4860 const ind_type
*i1
= (const ind_type
*) e1
;
4861 const ind_type
*i2
= (const ind_type
*) e2
;
4864 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4866 if (i1
->n
[i
] != i2
->n
[i
])
4867 return i1
->n
[i
] - i2
->n
[i
];
4869 /* All other things being equal, let's not change the ordering. */
4870 return i2
->num
- i1
->num
;
4873 /* Main function to do the index interchange. */
4876 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4877 void *data ATTRIBUTE_UNUSED
)
4882 gfc_forall_iterator
*fa
;
4886 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4890 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4893 /* Nothing to reorder. */
4897 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4900 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4902 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4904 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4909 ind
[n_iter
].sym
= NULL
;
4910 ind
[n_iter
].fa
= NULL
;
4912 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4913 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4915 /* Do the actual index interchange. */
4916 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4917 for (i
=1; i
<n_iter
; i
++)
4919 fa
->next
= ind
[i
].fa
;
4924 if (flag_warn_frontend_loop_interchange
)
4926 for (i
=1; i
<n_iter
; i
++)
4928 if (ind
[i
-1].num
> ind
[i
].num
)
4930 gfc_warning (OPT_Wfrontend_loop_interchange
,
4931 "Interchanging loops at %L", &co
->loc
);
4940 #define WALK_SUBEXPR(NODE) \
4943 result = gfc_expr_walker (&(NODE), exprfn, data); \
4948 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4950 /* Walk expression *E, calling EXPRFN on each expression in it. */
4953 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4957 int walk_subtrees
= 1;
4958 gfc_actual_arglist
*a
;
4962 int result
= exprfn (e
, &walk_subtrees
, data
);
4966 switch ((*e
)->expr_type
)
4969 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4970 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4973 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4974 WALK_SUBEXPR (a
->expr
);
4978 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4979 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4980 WALK_SUBEXPR (a
->expr
);
4983 case EXPR_STRUCTURE
:
4985 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4986 c
= gfc_constructor_next (c
))
4988 if (c
->iterator
== NULL
)
4989 WALK_SUBEXPR (c
->expr
);
4993 WALK_SUBEXPR (c
->expr
);
4995 WALK_SUBEXPR (c
->iterator
->var
);
4996 WALK_SUBEXPR (c
->iterator
->start
);
4997 WALK_SUBEXPR (c
->iterator
->end
);
4998 WALK_SUBEXPR (c
->iterator
->step
);
5002 if ((*e
)->expr_type
!= EXPR_ARRAY
)
5005 /* Fall through to the variable case in order to walk the
5009 case EXPR_SUBSTRING
:
5011 for (r
= (*e
)->ref
; r
; r
= r
->next
)
5020 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
5022 for (i
=0; i
< ar
->dimen
; i
++)
5024 WALK_SUBEXPR (ar
->start
[i
]);
5025 WALK_SUBEXPR (ar
->end
[i
]);
5026 WALK_SUBEXPR (ar
->stride
[i
]);
5033 WALK_SUBEXPR (r
->u
.ss
.start
);
5034 WALK_SUBEXPR (r
->u
.ss
.end
);
5050 #define WALK_SUBCODE(NODE) \
5053 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5059 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5060 on each expression in it. If any of the hooks returns non-zero, that
5061 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5062 no subcodes or subexpressions are traversed. */
5065 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5068 for (; *c
; c
= &(*c
)->next
)
5070 int walk_subtrees
= 1;
5071 int result
= codefn (c
, &walk_subtrees
, data
);
5078 gfc_actual_arglist
*a
;
5080 gfc_association_list
*alist
;
5081 bool saved_in_omp_workshare
;
5082 bool saved_in_where
;
5084 /* There might be statement insertions before the current code,
5085 which must not affect the expression walker. */
5088 saved_in_omp_workshare
= in_omp_workshare
;
5089 saved_in_where
= in_where
;
5095 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5096 if (co
->ext
.block
.assoc
)
5098 bool saved_in_assoc_list
= in_assoc_list
;
5100 in_assoc_list
= true;
5101 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5102 WALK_SUBEXPR (alist
->target
);
5104 in_assoc_list
= saved_in_assoc_list
;
5111 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5112 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5113 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5114 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5126 case EXEC_ASSIGN_CALL
:
5127 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5128 WALK_SUBEXPR (a
->expr
);
5132 WALK_SUBEXPR (co
->expr1
);
5133 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5134 WALK_SUBEXPR (a
->expr
);
5138 WALK_SUBEXPR (co
->expr1
);
5140 for (b
= co
->block
; b
; b
= b
->block
)
5143 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5145 WALK_SUBEXPR (cp
->low
);
5146 WALK_SUBEXPR (cp
->high
);
5148 WALK_SUBCODE (b
->next
);
5153 case EXEC_DEALLOCATE
:
5156 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5157 WALK_SUBEXPR (a
->expr
);
5162 case EXEC_DO_CONCURRENT
:
5164 gfc_forall_iterator
*fa
;
5165 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5167 WALK_SUBEXPR (fa
->var
);
5168 WALK_SUBEXPR (fa
->start
);
5169 WALK_SUBEXPR (fa
->end
);
5170 WALK_SUBEXPR (fa
->stride
);
5172 if (co
->op
== EXEC_FORALL
)
5178 WALK_SUBEXPR (co
->ext
.open
->unit
);
5179 WALK_SUBEXPR (co
->ext
.open
->file
);
5180 WALK_SUBEXPR (co
->ext
.open
->status
);
5181 WALK_SUBEXPR (co
->ext
.open
->access
);
5182 WALK_SUBEXPR (co
->ext
.open
->form
);
5183 WALK_SUBEXPR (co
->ext
.open
->recl
);
5184 WALK_SUBEXPR (co
->ext
.open
->blank
);
5185 WALK_SUBEXPR (co
->ext
.open
->position
);
5186 WALK_SUBEXPR (co
->ext
.open
->action
);
5187 WALK_SUBEXPR (co
->ext
.open
->delim
);
5188 WALK_SUBEXPR (co
->ext
.open
->pad
);
5189 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5190 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5191 WALK_SUBEXPR (co
->ext
.open
->convert
);
5192 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5193 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5194 WALK_SUBEXPR (co
->ext
.open
->round
);
5195 WALK_SUBEXPR (co
->ext
.open
->sign
);
5196 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5197 WALK_SUBEXPR (co
->ext
.open
->id
);
5198 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5199 WALK_SUBEXPR (co
->ext
.open
->share
);
5200 WALK_SUBEXPR (co
->ext
.open
->cc
);
5204 WALK_SUBEXPR (co
->ext
.close
->unit
);
5205 WALK_SUBEXPR (co
->ext
.close
->status
);
5206 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5207 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5210 case EXEC_BACKSPACE
:
5214 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5215 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5216 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5220 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5221 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5222 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5223 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5224 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5225 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5226 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5227 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5228 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5229 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5230 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5231 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5232 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5233 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5234 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5235 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5236 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5237 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5238 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5239 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5240 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5241 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5242 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5243 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5244 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5245 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5246 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5247 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5248 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5249 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5250 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5251 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5252 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5253 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5254 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5255 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5259 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5260 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5261 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5262 WALK_SUBEXPR (co
->ext
.wait
->id
);
5267 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5268 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5269 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5270 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5271 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5272 WALK_SUBEXPR (co
->ext
.dt
->size
);
5273 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5274 WALK_SUBEXPR (co
->ext
.dt
->id
);
5275 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5276 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5277 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5278 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5279 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5280 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5281 WALK_SUBEXPR (co
->ext
.dt
->round
);
5282 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5283 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5286 case EXEC_OMP_PARALLEL
:
5287 case EXEC_OMP_PARALLEL_DO
:
5288 case EXEC_OMP_PARALLEL_DO_SIMD
:
5289 case EXEC_OMP_PARALLEL_SECTIONS
:
5291 in_omp_workshare
= false;
5293 /* This goto serves as a shortcut to avoid code
5294 duplication or a larger if or switch statement. */
5295 goto check_omp_clauses
;
5297 case EXEC_OMP_WORKSHARE
:
5298 case EXEC_OMP_PARALLEL_WORKSHARE
:
5300 in_omp_workshare
= true;
5304 case EXEC_OMP_CRITICAL
:
5305 case EXEC_OMP_DISTRIBUTE
:
5306 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5307 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5308 case EXEC_OMP_DISTRIBUTE_SIMD
:
5310 case EXEC_OMP_DO_SIMD
:
5311 case EXEC_OMP_ORDERED
:
5312 case EXEC_OMP_SECTIONS
:
5313 case EXEC_OMP_SINGLE
:
5314 case EXEC_OMP_END_SINGLE
:
5316 case EXEC_OMP_TASKLOOP
:
5317 case EXEC_OMP_TASKLOOP_SIMD
:
5318 case EXEC_OMP_TARGET
:
5319 case EXEC_OMP_TARGET_DATA
:
5320 case EXEC_OMP_TARGET_ENTER_DATA
:
5321 case EXEC_OMP_TARGET_EXIT_DATA
:
5322 case EXEC_OMP_TARGET_PARALLEL
:
5323 case EXEC_OMP_TARGET_PARALLEL_DO
:
5324 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5325 case EXEC_OMP_TARGET_SIMD
:
5326 case EXEC_OMP_TARGET_TEAMS
:
5327 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5328 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5329 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5330 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5331 case EXEC_OMP_TARGET_UPDATE
:
5333 case EXEC_OMP_TEAMS
:
5334 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5335 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5336 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5337 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5339 /* Come to this label only from the
5340 EXEC_OMP_PARALLEL_* cases above. */
5344 if (co
->ext
.omp_clauses
)
5346 gfc_omp_namelist
*n
;
5347 static int list_types
[]
5348 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5349 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5351 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5352 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5353 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5354 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5355 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5356 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5357 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5358 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5359 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5360 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5361 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5362 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5363 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5364 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5365 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5366 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5368 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5370 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5372 WALK_SUBEXPR (n
->expr
);
5379 WALK_SUBEXPR (co
->expr1
);
5380 WALK_SUBEXPR (co
->expr2
);
5381 WALK_SUBEXPR (co
->expr3
);
5382 WALK_SUBEXPR (co
->expr4
);
5383 for (b
= co
->block
; b
; b
= b
->block
)
5385 WALK_SUBEXPR (b
->expr1
);
5386 WALK_SUBEXPR (b
->expr2
);
5387 WALK_SUBCODE (b
->next
);
5390 if (co
->op
== EXEC_FORALL
)
5393 if (co
->op
== EXEC_DO
)
5396 if (co
->op
== EXEC_IF
)
5399 if (co
->op
== EXEC_SELECT
)
5402 in_omp_workshare
= saved_in_omp_workshare
;
5403 in_where
= saved_in_where
;