1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2021 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 int matmul_temp_args (gfc_code
**, int *,void *data
);
58 static int index_interchange (gfc_code
**, int*, void *);
59 static bool is_fe_temp (gfc_expr
*e
);
62 static void check_locus (gfc_namespace
*);
65 /* How deep we are inside an argument list. */
67 static int count_arglist
;
69 /* Vector of gfc_expr ** we operate on. */
71 static vec
<gfc_expr
**> expr_array
;
73 /* Pointer to the gfc_code we currently work on - to be able to insert
74 a block before the statement. */
76 static gfc_code
**current_code
;
78 /* Pointer to the block to be inserted, and the statement we are
79 changing within the block. */
81 static gfc_code
*inserted_block
, **changed_statement
;
83 /* The namespace we are currently dealing with. */
85 static gfc_namespace
*current_ns
;
87 /* If we are within any forall loop. */
89 static int forall_level
;
91 /* Keep track of whether we are within an OMP workshare. */
93 static bool in_omp_workshare
;
95 /* Keep track of whether we are within an OMP atomic. */
97 static bool in_omp_atomic
;
99 /* Keep track of whether we are within a WHERE statement. */
101 static bool in_where
;
103 /* Keep track of iterators for array constructors. */
105 static int iterator_level
;
107 /* Keep track of DO loop levels. */
115 static vec
<do_t
> doloop_list
;
116 static int doloop_level
;
118 /* Keep track of if and select case levels. */
121 static int select_level
;
123 /* Vector of gfc_expr * to keep track of DO loops. */
125 struct my_struct
*evec
;
127 /* Keep track of association lists. */
129 static bool in_assoc_list
;
131 /* Counter for temporary variables. */
133 static int var_num
= 1;
135 /* What sort of matrix we are dealing with when inlining MATMUL. */
137 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
139 /* Keep track of the number of expressions we have inserted so far
144 /* Entry point - run all passes for a namespace. */
147 gfc_run_passes (gfc_namespace
*ns
)
150 /* Warn about dubious DO loops where the index might
157 doloop_list
.release ();
164 gfc_get_errors (&w
, &e
);
168 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
169 optimize_namespace (ns
);
171 if (flag_frontend_optimize
)
173 optimize_reduction (ns
);
174 if (flag_dump_fortran_optimized
)
175 gfc_dump_parse_tree (ns
, stdout
);
177 expr_array
.release ();
180 if (flag_realloc_lhs
)
181 realloc_strings (ns
);
186 /* Callback function: Warn if there is no location information in a
190 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
191 void *data ATTRIBUTE_UNUSED
)
194 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
195 gfc_warning_internal (0, "Inconsistent internal state: "
196 "No location in statement");
202 /* Callback function: Warn if there is no location information in an
206 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
207 void *data ATTRIBUTE_UNUSED
)
210 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
211 gfc_warning_internal (0, "Inconsistent internal state: "
212 "No location in expression near %L",
213 &((*current_code
)->loc
));
217 /* Run check for missing location information. */
220 check_locus (gfc_namespace
*ns
)
222 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
224 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
226 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
233 /* Callback for each gfc_code node invoked from check_realloc_strings.
234 For an allocatable LHS string which also appears as a variable on
246 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
247 void *data ATTRIBUTE_UNUSED
)
249 gfc_expr
*expr1
, *expr2
;
255 if (co
->op
!= EXEC_ASSIGN
)
259 if (expr1
->ts
.type
!= BT_CHARACTER
260 || !gfc_expr_attr(expr1
).allocatable
261 || !expr1
->ts
.deferred
)
264 if (is_fe_temp (expr1
))
267 expr2
= gfc_discard_nops (co
->expr2
);
269 if (expr2
->expr_type
== EXPR_VARIABLE
)
271 found_substr
= false;
272 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
274 if (ref
->type
== REF_SUBSTRING
)
283 else if (expr2
->expr_type
!= EXPR_ARRAY
284 && (expr2
->expr_type
!= EXPR_OP
285 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
288 if (!gfc_check_dependency (expr1
, expr2
, true))
291 /* gfc_check_dependency doesn't always pick up identical expressions.
292 However, eliminating the above sends the compiler into an infinite
293 loop on valid expressions. Without this check, the gimplifier emits
294 an ICE for a = a, where a is deferred character length. */
295 if (!gfc_dep_compare_expr (expr1
, expr2
))
299 inserted_block
= NULL
;
300 changed_statement
= NULL
;
301 n
= create_var (expr2
, "realloc_string");
306 /* Callback for each gfc_code node invoked through gfc_code_walker
307 from optimize_namespace. */
310 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
311 void *data ATTRIBUTE_UNUSED
)
318 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
319 || op
== EXEC_CALL_PPC
)
325 inserted_block
= NULL
;
326 changed_statement
= NULL
;
328 if (op
== EXEC_ASSIGN
)
329 optimize_assignment (*c
);
333 /* Callback for each gfc_expr node invoked through gfc_code_walker
334 from optimize_namespace. */
337 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
338 void *data ATTRIBUTE_UNUSED
)
342 if ((*e
)->expr_type
== EXPR_FUNCTION
)
345 function_expr
= true;
348 function_expr
= false;
350 if (optimize_trim (*e
))
351 gfc_simplify_expr (*e
, 0);
353 if (optimize_lexical_comparison (*e
))
354 gfc_simplify_expr (*e
, 0);
356 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
357 gfc_simplify_expr (*e
, 0);
359 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
360 switch ((*e
)->value
.function
.isym
->id
)
362 case GFC_ISYM_MINLOC
:
363 case GFC_ISYM_MAXLOC
:
364 optimize_minmaxloc (e
);
376 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
377 function is a scalar, just copy it; otherwise returns the new element, the
378 old one can be freed. */
381 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
383 gfc_expr
*fcn
, *e
= c
->expr
;
385 fcn
= gfc_copy_expr (e
);
388 gfc_constructor_base newbase
;
390 gfc_constructor
*new_c
;
393 new_expr
= gfc_get_expr ();
394 new_expr
->expr_type
= EXPR_ARRAY
;
395 new_expr
->ts
= e
->ts
;
396 new_expr
->where
= e
->where
;
398 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
399 new_c
->iterator
= c
->iterator
;
400 new_expr
->value
.constructor
= newbase
;
408 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
410 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
411 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
412 fn
->value
.function
.isym
->name
,
413 fn
->where
, 3, fcn
, NULL
, NULL
);
414 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
415 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
416 fn
->value
.function
.isym
->name
,
417 fn
->where
, 2, fcn
, NULL
);
419 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
421 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
427 /* Callback function for optimzation of reductions to scalars. Transform ANY
428 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
429 correspondingly. Handly only the simple cases without MASK and DIM. */
432 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
433 void *data ATTRIBUTE_UNUSED
)
438 gfc_actual_arglist
*a
;
439 gfc_actual_arglist
*dim
;
441 gfc_expr
*res
, *new_expr
;
442 gfc_actual_arglist
*mask
;
446 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
447 || fn
->value
.function
.isym
== NULL
)
450 id
= fn
->value
.function
.isym
->id
;
452 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
453 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
456 a
= fn
->value
.function
.actual
;
458 /* Don't handle MASK or DIM. */
462 if (dim
->expr
!= NULL
)
465 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
468 if ( mask
->expr
!= NULL
)
474 if (arg
->expr_type
!= EXPR_ARRAY
)
483 case GFC_ISYM_PRODUCT
:
484 op
= INTRINSIC_TIMES
;
499 c
= gfc_constructor_first (arg
->value
.constructor
);
501 /* Don't do any simplififcation if we have
502 - no element in the constructor or
503 - only have a single element in the array which contains an
509 res
= copy_walk_reduction_arg (c
, fn
);
511 c
= gfc_constructor_next (c
);
514 new_expr
= gfc_get_expr ();
515 new_expr
->ts
= fn
->ts
;
516 new_expr
->expr_type
= EXPR_OP
;
517 new_expr
->rank
= fn
->rank
;
518 new_expr
->where
= fn
->where
;
519 new_expr
->value
.op
.op
= op
;
520 new_expr
->value
.op
.op1
= res
;
521 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
523 c
= gfc_constructor_next (c
);
526 gfc_simplify_expr (res
, 0);
533 /* Callback function for common function elimination, called from cfe_expr_0.
534 Put all eligible function expressions into expr_array. */
537 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
538 void *data ATTRIBUTE_UNUSED
)
541 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
544 /* We don't do character functions with unknown charlens. */
545 if ((*e
)->ts
.type
== BT_CHARACTER
546 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
547 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
550 /* We don't do function elimination within FORALL statements, it can
551 lead to wrong-code in certain circumstances. */
553 if (forall_level
> 0)
556 /* Function elimination inside an iterator could lead to functions which
557 depend on iterator variables being moved outside. FIXME: We should check
558 if the functions do indeed depend on the iterator variable. */
560 if (iterator_level
> 0)
563 /* If we don't know the shape at compile time, we create an allocatable
564 temporary variable to hold the intermediate result, but only if
565 allocation on assignment is active. */
567 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
570 /* Skip the test for pure functions if -faggressive-function-elimination
572 if ((*e
)->value
.function
.esym
)
574 /* Don't create an array temporary for elemental functions. */
575 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
578 /* Only eliminate potentially impure functions if the
579 user specifically requested it. */
580 if (!flag_aggressive_function_elimination
581 && !(*e
)->value
.function
.esym
->attr
.pure
582 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
586 if ((*e
)->value
.function
.isym
)
588 /* Conversions are handled on the fly by the middle end,
589 transpose during trans-* stages and TRANSFER by the middle end. */
590 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
591 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
592 || gfc_inline_intrinsic_function_p (*e
))
595 /* Don't create an array temporary for elemental functions,
596 as this would be wasteful of memory.
597 FIXME: Create a scalar temporary during scalarization. */
598 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
601 if (!(*e
)->value
.function
.isym
->pure
)
605 expr_array
.safe_push (e
);
609 /* Auxiliary function to check if an expression is a temporary created by
613 is_fe_temp (gfc_expr
*e
)
615 if (e
->expr_type
!= EXPR_VARIABLE
)
618 return e
->symtree
->n
.sym
->attr
.fe_temp
;
621 /* Determine the length of a string, if it can be evaluated as a constant
622 expression. Return a newly allocated gfc_expr or NULL on failure.
623 If the user specified a substring which is potentially longer than
624 the string itself, the string will be padded with spaces, which
628 constant_string_length (gfc_expr
*e
)
638 length
= e
->ts
.u
.cl
->length
;
639 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
640 return gfc_copy_expr(length
);
643 /* See if there is a substring. If it has a constant length, return
644 that and NULL otherwise. */
645 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
647 if (ref
->type
== REF_SUBSTRING
)
649 if (gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
651 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
654 mpz_add_ui (res
->value
.integer
, value
, 1);
663 /* Return length of char symbol, if constant. */
664 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
665 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
666 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
667 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
673 /* Insert a block at the current position unless it has already
674 been inserted; in this case use the one already there. */
676 static gfc_namespace
*
681 /* If the block hasn't already been created, do so. */
682 if (inserted_block
== NULL
)
684 inserted_block
= XCNEW (gfc_code
);
685 inserted_block
->op
= EXEC_BLOCK
;
686 inserted_block
->loc
= (*current_code
)->loc
;
687 ns
= gfc_build_block_ns (current_ns
);
688 inserted_block
->ext
.block
.ns
= ns
;
689 inserted_block
->ext
.block
.assoc
= NULL
;
691 ns
->code
= *current_code
;
693 /* If the statement has a label, make sure it is transferred to
694 the newly created block. */
696 if ((*current_code
)->here
)
698 inserted_block
->here
= (*current_code
)->here
;
699 (*current_code
)->here
= NULL
;
702 inserted_block
->next
= (*current_code
)->next
;
703 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
704 (*current_code
)->next
= NULL
;
705 /* Insert the BLOCK at the right position. */
706 *current_code
= inserted_block
;
707 ns
->parent
= current_ns
;
710 ns
= inserted_block
->ext
.block
.ns
;
716 /* Insert a call to the intrinsic len. Use a different name for
717 the symbol tree so we don't run into trouble when the user has
718 renamed len for some reason. */
721 get_len_call (gfc_expr
*str
)
724 gfc_actual_arglist
*actual_arglist
;
726 fcn
= gfc_get_expr ();
727 fcn
->expr_type
= EXPR_FUNCTION
;
728 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN
);
729 actual_arglist
= gfc_get_actual_arglist ();
730 actual_arglist
->expr
= str
;
732 fcn
->value
.function
.actual
= actual_arglist
;
733 fcn
->where
= str
->where
;
734 fcn
->ts
.type
= BT_INTEGER
;
735 fcn
->ts
.kind
= gfc_charlen_int_kind
;
737 gfc_get_sym_tree ("__internal_len", current_ns
, &fcn
->symtree
, false);
738 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
739 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
740 fcn
->symtree
->n
.sym
->attr
.function
= 1;
741 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
742 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
743 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
744 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
750 /* Returns a new expression (a variable) to be used in place of the old one,
751 with an optional assignment statement before the current statement to set
752 the value of the variable. Creates a new BLOCK for the statement if that
753 hasn't already been done and puts the statement, plus the newly created
754 variables, in that block. Special cases: If the expression is constant or
755 a temporary which has already been created, just copy it. */
758 create_var (gfc_expr
* e
, const char *vname
)
760 char name
[GFC_MAX_SYMBOL_LEN
+1];
761 gfc_symtree
*symtree
;
769 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
770 return gfc_copy_expr (e
);
772 /* Creation of an array of unknown size requires realloc on assignment.
773 If that is not possible, just return NULL. */
774 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
777 ns
= insert_block ();
780 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
782 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
784 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
787 symbol
= symtree
->n
.sym
;
792 symbol
->as
= gfc_get_array_spec ();
793 symbol
->as
->rank
= e
->rank
;
795 if (e
->shape
== NULL
)
797 /* We don't know the shape at compile time, so we use an
799 symbol
->as
->type
= AS_DEFERRED
;
800 symbol
->attr
.allocatable
= 1;
804 symbol
->as
->type
= AS_EXPLICIT
;
805 /* Copy the shape. */
806 for (i
=0; i
<e
->rank
; i
++)
810 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
812 mpz_set_si (p
->value
.integer
, 1);
813 symbol
->as
->lower
[i
] = p
;
815 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
817 mpz_set (q
->value
.integer
, e
->shape
[i
]);
818 symbol
->as
->upper
[i
] = q
;
824 if (e
->ts
.type
== BT_CHARACTER
)
828 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
829 length
= constant_string_length (e
);
831 symbol
->ts
.u
.cl
->length
= length
;
832 else if (e
->expr_type
== EXPR_VARIABLE
833 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
834 && e
->ts
.u
.cl
->length
)
835 symbol
->ts
.u
.cl
->length
= get_len_call (gfc_copy_expr (e
));
838 symbol
->attr
.allocatable
= 1;
839 symbol
->ts
.u
.cl
->length
= NULL
;
840 symbol
->ts
.deferred
= 1;
845 symbol
->attr
.flavor
= FL_VARIABLE
;
846 symbol
->attr
.referenced
= 1;
847 symbol
->attr
.dimension
= e
->rank
> 0;
848 symbol
->attr
.fe_temp
= 1;
849 gfc_commit_symbol (symbol
);
851 result
= gfc_get_expr ();
852 result
->expr_type
= EXPR_VARIABLE
;
853 result
->ts
= symbol
->ts
;
854 result
->ts
.deferred
= deferred
;
855 result
->rank
= e
->rank
;
856 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
857 result
->symtree
= symtree
;
858 result
->where
= e
->where
;
861 result
->ref
= gfc_get_ref ();
862 result
->ref
->type
= REF_ARRAY
;
863 result
->ref
->u
.ar
.type
= AR_FULL
;
864 result
->ref
->u
.ar
.where
= e
->where
;
865 result
->ref
->u
.ar
.dimen
= e
->rank
;
866 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
867 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
868 if (warn_array_temporaries
)
869 gfc_warning (OPT_Warray_temporaries
,
870 "Creating array temporary at %L", &(e
->where
));
873 /* Generate the new assignment. */
874 n
= XCNEW (gfc_code
);
876 n
->loc
= (*current_code
)->loc
;
877 n
->next
= *changed_statement
;
878 n
->expr1
= gfc_copy_expr (result
);
880 *changed_statement
= n
;
886 /* Warn about function elimination. */
889 do_warn_function_elimination (gfc_expr
*e
)
892 if (e
->expr_type
== EXPR_FUNCTION
893 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
896 gfc_warning (OPT_Wfunction_elimination
,
897 "Removing call to impure function %qs at %L", name
,
900 gfc_warning (OPT_Wfunction_elimination
,
901 "Removing call to impure function at %L",
907 /* Callback function for the code walker for doing common function
908 elimination. This builds up the list of functions in the expression
909 and goes through them to detect duplicates, which it then replaces
913 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
914 void *data ATTRIBUTE_UNUSED
)
920 /* Don't do this optimization within OMP workshare/atomic or ASSOC lists. */
922 if (in_omp_workshare
|| in_omp_atomic
|| in_assoc_list
)
928 expr_array
.release ();
930 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
932 /* Walk through all the functions. */
934 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
936 /* Skip if the function has been replaced by a variable already. */
937 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
944 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
947 newvar
= create_var (*ei
, "fcn");
949 if (warn_function_elimination
)
950 do_warn_function_elimination (*ej
);
953 *ej
= gfc_copy_expr (newvar
);
960 /* We did all the necessary walking in this function. */
965 /* Callback function for common function elimination, called from
966 gfc_code_walker. This keeps track of the current code, in order
967 to insert statements as needed. */
970 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
973 inserted_block
= NULL
;
974 changed_statement
= NULL
;
976 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
977 and allocation on assigment are prohibited inside WHERE, and finally
978 masking an expression would lead to wrong-code when replacing
981 b = sum(foo(a) + foo(a))
992 if ((*c
)->op
== EXEC_WHERE
)
1002 /* Dummy function for expression call back, for use when we
1003 really don't want to do any walking. */
1006 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
1007 void *data ATTRIBUTE_UNUSED
)
1013 /* Dummy function for code callback, for use when we really
1014 don't want to do anything. */
1016 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
1017 int *walk_subtrees ATTRIBUTE_UNUSED
,
1018 void *data ATTRIBUTE_UNUSED
)
1023 /* Code callback function for converting
1030 This is because common function elimination would otherwise place the
1031 temporary variables outside the loop. */
1034 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1035 void *data ATTRIBUTE_UNUSED
)
1038 gfc_code
*c_if1
, *c_if2
, *c_exit
;
1039 gfc_code
*loopblock
;
1040 gfc_expr
*e_not
, *e_cond
;
1042 if (co
->op
!= EXEC_DO_WHILE
)
1045 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1050 /* Generate the condition of the if statement, which is .not. the original
1052 e_not
= gfc_get_expr ();
1053 e_not
->ts
= e_cond
->ts
;
1054 e_not
->where
= e_cond
->where
;
1055 e_not
->expr_type
= EXPR_OP
;
1056 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1057 e_not
->value
.op
.op1
= e_cond
;
1059 /* Generate the EXIT statement. */
1060 c_exit
= XCNEW (gfc_code
);
1061 c_exit
->op
= EXEC_EXIT
;
1062 c_exit
->ext
.which_construct
= co
;
1063 c_exit
->loc
= co
->loc
;
1065 /* Generate the IF statement. */
1066 c_if2
= XCNEW (gfc_code
);
1067 c_if2
->op
= EXEC_IF
;
1068 c_if2
->expr1
= e_not
;
1069 c_if2
->next
= c_exit
;
1070 c_if2
->loc
= co
->loc
;
1072 /* ... plus the one to chain it to. */
1073 c_if1
= XCNEW (gfc_code
);
1074 c_if1
->op
= EXEC_IF
;
1075 c_if1
->block
= c_if2
;
1076 c_if1
->loc
= co
->loc
;
1078 /* Make the DO WHILE loop into a DO block by replacing the condition
1079 with a true constant. */
1080 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1082 /* Hang the generated if statement into the loop body. */
1084 loopblock
= co
->block
->next
;
1085 co
->block
->next
= c_if1
;
1086 c_if1
->next
= loopblock
;
1091 /* Code callback function for converting
1104 because otherwise common function elimination would place the BLOCKs
1105 into the wrong place. */
1108 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1109 void *data ATTRIBUTE_UNUSED
)
1112 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1114 if (co
->op
!= EXEC_IF
)
1117 /* This loop starts out with the first ELSE statement. */
1118 else_stmt
= co
->block
->block
;
1120 while (else_stmt
!= NULL
)
1122 gfc_code
*next_else
;
1124 /* If there is no condition, we're done. */
1125 if (else_stmt
->expr1
== NULL
)
1128 next_else
= else_stmt
->block
;
1130 /* Generate the new IF statement. */
1131 c_if2
= XCNEW (gfc_code
);
1132 c_if2
->op
= EXEC_IF
;
1133 c_if2
->expr1
= else_stmt
->expr1
;
1134 c_if2
->next
= else_stmt
->next
;
1135 c_if2
->loc
= else_stmt
->loc
;
1136 c_if2
->block
= next_else
;
1138 /* ... plus the one to chain it to. */
1139 c_if1
= XCNEW (gfc_code
);
1140 c_if1
->op
= EXEC_IF
;
1141 c_if1
->block
= c_if2
;
1142 c_if1
->loc
= else_stmt
->loc
;
1144 /* Insert the new IF after the ELSE. */
1145 else_stmt
->expr1
= NULL
;
1146 else_stmt
->next
= c_if1
;
1147 else_stmt
->block
= NULL
;
1149 else_stmt
= next_else
;
1151 /* Don't walk subtrees. */
1155 /* Callback function to var_in_expr - return true if expr1 and
1156 expr2 are identical variables. */
1158 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1161 gfc_expr
*expr1
= (gfc_expr
*) data
;
1162 gfc_expr
*expr2
= *e
;
1164 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1167 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1170 /* Return true if expr1 is found in expr2. */
1173 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1175 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1177 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1182 struct do_stack
*prev
;
1187 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1188 optimize by replacing do loops with their analog array slices. For
1191 write (*,*) (a(i), i=1,4)
1195 write (*,*) a(1:4:1) . */
1198 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1201 gfc_expr
*new_e
, *expr
, *start
;
1203 struct do_stack ds_push
;
1204 int i
, future_rank
= 0;
1205 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1208 /* Find the first transfer/do statement. */
1209 for (curr
= code
; curr
; curr
= curr
->next
)
1211 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1215 /* Ensure it is the only transfer/do statement because cases like
1217 write (*,*) (a(i), b(i), i=1,4)
1219 cannot be optimized. */
1221 if (!curr
|| curr
->next
)
1224 if (curr
->op
== EXEC_DO
)
1226 if (curr
->ext
.iterator
->var
->ref
)
1228 ds_push
.prev
= stack_top
;
1229 ds_push
.iter
= curr
->ext
.iterator
;
1230 ds_push
.code
= curr
;
1231 stack_top
= &ds_push
;
1232 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1234 if (curr
!= stack_top
->code
&& !*has_reached
)
1236 curr
->block
->next
= NULL
;
1237 gfc_free_statements (curr
);
1240 *has_reached
= true;
1246 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1250 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1253 /* Find the iterators belonging to each variable and check conditions. */
1254 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1256 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1257 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1260 start
= ref
->u
.ar
.start
[i
];
1261 gfc_simplify_expr (start
, 0);
1262 switch (start
->expr_type
)
1266 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1270 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1271 if (!stack_top
|| !stack_top
->iter
1272 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1274 /* Check for (a(i,i), i=1,3). */
1278 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1285 iters
[i
] = stack_top
->iter
;
1286 stack_top
= stack_top
->prev
;
1294 switch (start
->value
.op
.op
)
1296 case INTRINSIC_PLUS
:
1297 case INTRINSIC_TIMES
:
1298 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1299 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1301 case INTRINSIC_MINUS
:
1302 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1303 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1304 || start
->value
.op
.op1
->ref
)
1306 if (!stack_top
|| !stack_top
->iter
1307 || stack_top
->iter
->var
->symtree
1308 != start
->value
.op
.op1
->symtree
)
1310 iters
[i
] = stack_top
->iter
;
1311 stack_top
= stack_top
->prev
;
1323 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1324 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1328 gfc_expr
*var
= iters
[i
]->var
;
1329 for (int j
= i
- 1; j
< i
; j
++)
1332 && (var_in_expr (var
, iters
[j
]->start
)
1333 || var_in_expr (var
, iters
[j
]->end
)
1334 || var_in_expr (var
, iters
[j
]->step
)))
1340 /* Create new expr. */
1341 new_e
= gfc_copy_expr (curr
->expr1
);
1342 new_e
->expr_type
= EXPR_VARIABLE
;
1343 new_e
->rank
= future_rank
;
1344 if (curr
->expr1
->shape
)
1345 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1347 /* Assign new starts, ends and strides if necessary. */
1348 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1352 start
= ref
->u
.ar
.start
[i
];
1353 switch (start
->expr_type
)
1356 gfc_internal_error ("bad expression");
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 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1363 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1364 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1367 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1368 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1369 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1370 expr
= gfc_copy_expr (start
);
1371 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1372 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1373 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1374 expr
= gfc_copy_expr (start
);
1375 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1376 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1377 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1378 switch (start
->value
.op
.op
)
1380 case INTRINSIC_MINUS
:
1381 case INTRINSIC_PLUS
:
1382 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1384 case INTRINSIC_TIMES
:
1385 expr
= gfc_copy_expr (start
);
1386 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1387 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1388 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1391 gfc_internal_error ("bad op");
1395 gfc_internal_error ("bad expression");
1398 curr
->expr1
= new_e
;
1400 /* Insert modified statement. Check whether the statement needs to be
1401 inserted at the lowest level. */
1402 if (!stack_top
->iter
)
1406 curr
->next
= prev
->next
->next
;
1411 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1412 stack_top
->code
->block
->next
= curr
;
1416 stack_top
->code
->block
->next
= curr
;
1420 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1421 tries to optimize its block. */
1424 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1425 void *data ATTRIBUTE_UNUSED
)
1427 gfc_code
**curr
, *prev
= NULL
;
1428 struct do_stack write
, first
;
1432 || ((*code
)->block
->op
!= EXEC_WRITE
1433 && (*code
)->block
->op
!= EXEC_READ
))
1441 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1443 if ((*curr
)->op
== EXEC_DO
)
1445 first
.prev
= &write
;
1446 first
.iter
= (*curr
)->ext
.iterator
;
1449 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1457 /* Optimize a namespace, including all contained namespaces.
1458 flag_frontend_optimize and flag_fronend_loop_interchange are
1459 handled separately. */
1462 optimize_namespace (gfc_namespace
*ns
)
1464 gfc_namespace
*saved_ns
= gfc_current_ns
;
1466 gfc_current_ns
= ns
;
1469 in_assoc_list
= false;
1470 in_omp_workshare
= false;
1471 in_omp_atomic
= false;
1473 if (flag_frontend_optimize
)
1475 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1476 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1477 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1478 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1479 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1480 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1486 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1491 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1495 if (flag_external_blas
)
1496 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1499 if (flag_inline_matmul_limit
!= 0)
1500 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1504 if (flag_frontend_loop_interchange
)
1505 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1508 /* BLOCKs are handled in the expression walker below. */
1509 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1511 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1512 optimize_namespace (ns
);
1514 gfc_current_ns
= saved_ns
;
1517 /* Handle dependencies for allocatable strings which potentially redefine
1518 themselves in an assignment. */
1521 realloc_strings (gfc_namespace
*ns
)
1524 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1526 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1528 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1529 realloc_strings (ns
);
1535 optimize_reduction (gfc_namespace
*ns
)
1538 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1539 callback_reduction
, NULL
);
1541 /* BLOCKs are handled in the expression walker below. */
1542 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1544 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1545 optimize_reduction (ns
);
1549 /* Replace code like
1552 a = matmul(b,c) ; a = a + d
1553 where the array function is not elemental and not allocatable
1554 and does not depend on the left-hand side.
1558 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1566 if (e
->expr_type
== EXPR_OP
)
1568 switch (e
->value
.op
.op
)
1570 /* Unary operators and exponentiation: Only look at a single
1573 case INTRINSIC_UPLUS
:
1574 case INTRINSIC_UMINUS
:
1575 case INTRINSIC_PARENTHESES
:
1576 case INTRINSIC_POWER
:
1577 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1581 case INTRINSIC_CONCAT
:
1582 /* Do not do string concatenations. */
1586 /* Binary operators. */
1587 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1590 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1596 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1597 && ! (e
->value
.function
.esym
1598 && (e
->value
.function
.esym
->attr
.elemental
1599 || e
->value
.function
.esym
->attr
.allocatable
1600 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1601 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1602 && ! (e
->value
.function
.isym
1603 && (e
->value
.function
.isym
->elemental
1604 || e
->ts
.type
!= c
->expr1
->ts
.type
1605 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1606 && ! gfc_inline_intrinsic_function_p (e
))
1612 /* Insert a new assignment statement after the current one. */
1613 n
= XCNEW (gfc_code
);
1614 n
->op
= EXEC_ASSIGN
;
1619 n
->expr1
= gfc_copy_expr (c
->expr1
);
1620 n
->expr2
= c
->expr2
;
1621 new_expr
= gfc_copy_expr (c
->expr1
);
1629 /* Nothing to optimize. */
1633 /* Remove unneeded TRIMs at the end of expressions. */
1636 remove_trim (gfc_expr
*rhs
)
1644 /* Check for a // b // trim(c). Looping is probably not
1645 necessary because the parser usually generates
1646 (// (// a b ) trim(c) ) , but better safe than sorry. */
1648 while (rhs
->expr_type
== EXPR_OP
1649 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1650 rhs
= rhs
->value
.op
.op2
;
1652 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1653 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1655 strip_function_call (rhs
);
1656 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1664 /* Optimizations for an assignment. */
1667 optimize_assignment (gfc_code
* c
)
1669 gfc_expr
*lhs
, *rhs
;
1674 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1676 /* Optimize a = trim(b) to a = b. */
1679 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1680 if (is_empty_string (rhs
))
1681 rhs
->value
.character
.length
= 0;
1684 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1685 optimize_binop_array_assignment (c
, &rhs
, false);
1689 /* Remove an unneeded function call, modifying the expression.
1690 This replaces the function call with the value of its
1691 first argument. The rest of the argument list is freed. */
1694 strip_function_call (gfc_expr
*e
)
1697 gfc_actual_arglist
*a
;
1699 a
= e
->value
.function
.actual
;
1701 /* We should have at least one argument. */
1702 gcc_assert (a
->expr
!= NULL
);
1706 /* Free the remaining arglist, if any. */
1708 gfc_free_actual_arglist (a
->next
);
1710 /* Graft the argument expression onto the original function. */
1716 /* Optimization of lexical comparison functions. */
1719 optimize_lexical_comparison (gfc_expr
*e
)
1721 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1724 switch (e
->value
.function
.isym
->id
)
1727 return optimize_comparison (e
, INTRINSIC_LE
);
1730 return optimize_comparison (e
, INTRINSIC_GE
);
1733 return optimize_comparison (e
, INTRINSIC_GT
);
1736 return optimize_comparison (e
, INTRINSIC_LT
);
1744 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1745 do CHARACTER because of possible pessimization involving character
1749 combine_array_constructor (gfc_expr
*e
)
1752 gfc_expr
*op1
, *op2
;
1755 gfc_constructor
*c
, *new_c
;
1756 gfc_constructor_base oldbase
, newbase
;
1761 /* Array constructors have rank one. */
1765 /* Don't try to combine association lists, this makes no sense
1766 and leads to an ICE. */
1770 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1771 if (forall_level
> 0)
1774 /* Inside an iterator, things can get hairy; we are likely to create
1775 an invalid temporary variable. */
1776 if (iterator_level
> 0)
1779 /* WHERE also doesn't work. */
1783 op1
= e
->value
.op
.op1
;
1784 op2
= e
->value
.op
.op2
;
1789 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1790 scalar_first
= false;
1791 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1793 scalar_first
= true;
1794 op1
= e
->value
.op
.op2
;
1795 op2
= e
->value
.op
.op1
;
1800 if (op2
->ts
.type
== BT_CHARACTER
)
1803 /* This might be an expanded constructor with very many constant values. If
1804 we perform the operation here, we might end up with a long compile time
1805 and actually longer execution time, so a length bound is in order here.
1806 If the constructor constains something which is not a constant, it did
1807 not come from an expansion, so leave it alone. */
1809 #define CONSTR_LEN_MAX 4
1811 oldbase
= op1
->value
.constructor
;
1815 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1817 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1825 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1828 #undef CONSTR_LEN_MAX
1831 e
->expr_type
= EXPR_ARRAY
;
1833 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1835 for (c
= gfc_constructor_first (oldbase
); c
;
1836 c
= gfc_constructor_next (c
))
1838 new_expr
= gfc_get_expr ();
1839 new_expr
->ts
= e
->ts
;
1840 new_expr
->expr_type
= EXPR_OP
;
1841 new_expr
->rank
= c
->expr
->rank
;
1842 new_expr
->where
= c
->expr
->where
;
1843 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1847 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1848 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1852 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1853 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1856 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1857 new_c
->iterator
= c
->iterator
;
1861 gfc_free_expr (op1
);
1862 gfc_free_expr (op2
);
1863 gfc_free_expr (scalar
);
1865 e
->value
.constructor
= newbase
;
1869 /* Recursive optimization of operators. */
1872 optimize_op (gfc_expr
*e
)
1876 gfc_intrinsic_op op
= e
->value
.op
.op
;
1880 /* Only use new-style comparisons. */
1883 case INTRINSIC_EQ_OS
:
1887 case INTRINSIC_GE_OS
:
1891 case INTRINSIC_LE_OS
:
1895 case INTRINSIC_NE_OS
:
1899 case INTRINSIC_GT_OS
:
1903 case INTRINSIC_LT_OS
:
1919 changed
= optimize_comparison (e
, op
);
1922 /* Look at array constructors. */
1923 case INTRINSIC_PLUS
:
1924 case INTRINSIC_MINUS
:
1925 case INTRINSIC_TIMES
:
1926 case INTRINSIC_DIVIDE
:
1927 return combine_array_constructor (e
) || changed
;
1937 /* Return true if a constant string contains only blanks. */
1940 is_empty_string (gfc_expr
*e
)
1944 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1947 for (i
=0; i
< e
->value
.character
.length
; i
++)
1949 if (e
->value
.character
.string
[i
] != ' ')
1957 /* Insert a call to the intrinsic len_trim. Use a different name for
1958 the symbol tree so we don't run into trouble when the user has
1959 renamed len_trim for some reason. */
1962 get_len_trim_call (gfc_expr
*str
, int kind
)
1965 gfc_actual_arglist
*actual_arglist
, *next
;
1967 fcn
= gfc_get_expr ();
1968 fcn
->expr_type
= EXPR_FUNCTION
;
1969 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1970 actual_arglist
= gfc_get_actual_arglist ();
1971 actual_arglist
->expr
= str
;
1972 next
= gfc_get_actual_arglist ();
1973 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1974 actual_arglist
->next
= next
;
1976 fcn
->value
.function
.actual
= actual_arglist
;
1977 fcn
->where
= str
->where
;
1978 fcn
->ts
.type
= BT_INTEGER
;
1979 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1981 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1982 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1983 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1984 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1985 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1986 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1987 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1988 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1994 /* Optimize expressions for equality. */
1997 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1999 gfc_expr
*op1
, *op2
;
2003 gfc_actual_arglist
*firstarg
, *secondarg
;
2005 if (e
->expr_type
== EXPR_OP
)
2009 op1
= e
->value
.op
.op1
;
2010 op2
= e
->value
.op
.op2
;
2012 else if (e
->expr_type
== EXPR_FUNCTION
)
2014 /* One of the lexical comparison functions. */
2015 firstarg
= e
->value
.function
.actual
;
2016 secondarg
= firstarg
->next
;
2017 op1
= firstarg
->expr
;
2018 op2
= secondarg
->expr
;
2023 /* Strip off unneeded TRIM calls from string comparisons. */
2025 change
= remove_trim (op1
);
2027 if (remove_trim (op2
))
2030 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2031 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2032 handles them well). However, there are also cases that need a non-scalar
2033 argument. For example the any intrinsic. See PR 45380. */
2037 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2039 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2040 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2042 bool empty_op1
, empty_op2
;
2043 empty_op1
= is_empty_string (op1
);
2044 empty_op2
= is_empty_string (op2
);
2046 if (empty_op1
|| empty_op2
)
2052 /* This can only happen when an error for comparing
2053 characters of different kinds has already been issued. */
2054 if (empty_op1
&& empty_op2
)
2057 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2058 str
= empty_op1
? op2
: op1
;
2060 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2064 gfc_free_expr (op1
);
2066 gfc_free_expr (op2
);
2070 e
->value
.op
.op1
= fcn
;
2071 e
->value
.op
.op2
= zero
;
2076 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2078 if (flag_finite_math_only
2079 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2080 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2082 eq
= gfc_dep_compare_expr (op1
, op2
);
2085 /* Replace A // B < A // C with B < C, and A // B < C // B
2087 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2088 && op1
->expr_type
== EXPR_OP
2089 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2090 && op2
->expr_type
== EXPR_OP
2091 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2093 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2094 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2095 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2096 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2098 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2100 /* Watch out for 'A ' // x vs. 'A' // x. */
2102 if (op1_left
->expr_type
== EXPR_CONSTANT
2103 && op2_left
->expr_type
== EXPR_CONSTANT
2104 && op1_left
->value
.character
.length
2105 != op2_left
->value
.character
.length
)
2113 firstarg
->expr
= op1_right
;
2114 secondarg
->expr
= op2_right
;
2118 e
->value
.op
.op1
= op1_right
;
2119 e
->value
.op
.op2
= op2_right
;
2121 optimize_comparison (e
, op
);
2125 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2131 firstarg
->expr
= op1_left
;
2132 secondarg
->expr
= op2_left
;
2136 e
->value
.op
.op1
= op1_left
;
2137 e
->value
.op
.op2
= op2_left
;
2140 optimize_comparison (e
, op
);
2147 /* eq can only be -1, 0 or 1 at this point. */
2175 gfc_internal_error ("illegal OP in optimize_comparison");
2179 /* Replace the expression by a constant expression. The typespec
2180 and where remains the way it is. */
2183 e
->expr_type
= EXPR_CONSTANT
;
2184 e
->value
.logical
= result
;
2192 /* Optimize a trim function by replacing it with an equivalent substring
2193 involving a call to len_trim. This only works for expressions where
2194 variables are trimmed. Return true if anything was modified. */
2197 optimize_trim (gfc_expr
*e
)
2202 gfc_ref
**rr
= NULL
;
2204 /* Don't do this optimization within an argument list, because
2205 otherwise aliasing issues may occur. */
2207 if (count_arglist
!= 1)
2210 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2211 || e
->value
.function
.isym
== NULL
2212 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2215 a
= e
->value
.function
.actual
->expr
;
2217 if (a
->expr_type
!= EXPR_VARIABLE
)
2220 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2222 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2225 /* Follow all references to find the correct place to put the newly
2226 created reference. FIXME: Also handle substring references and
2227 array references. Array references cause strange regressions at
2232 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2234 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2239 strip_function_call (e
);
2244 /* Create the reference. */
2246 ref
= gfc_get_ref ();
2247 ref
->type
= REF_SUBSTRING
;
2249 /* Set the start of the reference. */
2251 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2253 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2255 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2257 /* Set the end of the reference to the call to len_trim. */
2259 ref
->u
.ss
.end
= fcn
;
2260 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2265 /* Optimize minloc(b), where b is rank 1 array, into
2266 (/ minloc(b, dim=1) /), and similarly for maxloc,
2267 as the latter forms are expanded inline. */
2270 optimize_minmaxloc (gfc_expr
**e
)
2273 gfc_actual_arglist
*a
;
2277 || fn
->value
.function
.actual
== NULL
2278 || fn
->value
.function
.actual
->expr
== NULL
2279 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2282 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2283 (*e
)->shape
= fn
->shape
;
2286 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2288 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2289 strcpy (name
, fn
->value
.function
.name
);
2290 p
= strstr (name
, "loc0");
2292 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2293 if (fn
->value
.function
.actual
->next
)
2295 a
= fn
->value
.function
.actual
->next
;
2296 gcc_assert (a
->expr
== NULL
);
2300 a
= gfc_get_actual_arglist ();
2301 fn
->value
.function
.actual
->next
= a
;
2303 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2305 mpz_set_ui (a
->expr
->value
.integer
, 1);
2308 /* Data package to hand down for DO loop checks in a contained
2310 typedef struct contained_info
2313 gfc_symbol
*procedure
;
2317 static enum gfc_exec_op last_io_op
;
2319 /* Callback function to check for INTENT(OUT) and INTENT(INOUT) in a
2320 contained function call. */
2323 doloop_contained_function_call (gfc_expr
**e
,
2324 int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
2326 gfc_expr
*expr
= *e
;
2327 gfc_formal_arglist
*f
;
2328 gfc_actual_arglist
*a
;
2329 gfc_symbol
*sym
, *do_var
;
2330 contained_info
*info
;
2332 if (expr
->expr_type
!= EXPR_FUNCTION
|| expr
->value
.function
.isym
2333 || expr
->value
.function
.esym
== NULL
)
2336 sym
= expr
->value
.function
.esym
;
2337 f
= gfc_sym_get_dummy_args (sym
);
2341 info
= (contained_info
*) data
;
2342 do_var
= info
->do_var
;
2343 a
= expr
->value
.function
.actual
;
2347 if (a
->expr
&& a
->expr
->symtree
&& a
->expr
->symtree
->n
.sym
== do_var
)
2349 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2351 gfc_error_now ("Index variable %qs set to undefined as "
2352 "INTENT(OUT) argument at %L in procedure %qs "
2353 "called from within DO loop at %L", do_var
->name
,
2354 &a
->expr
->where
, info
->procedure
->name
,
2358 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2360 gfc_error_now ("Index variable %qs not definable as "
2361 "INTENT(INOUT) argument at %L in procedure %qs "
2362 "called from within DO loop at %L", do_var
->name
,
2363 &a
->expr
->where
, info
->procedure
->name
,
2374 /* Callback function that goes through the code in a contained
2375 procedure to make sure it does not change a variable in a DO
2379 doloop_contained_procedure_code (gfc_code
**c
,
2380 int *walk_subtrees ATTRIBUTE_UNUSED
,
2384 contained_info
*info
= (contained_info
*) data
;
2385 gfc_symbol
*do_var
= info
->do_var
;
2386 const char *errmsg
= _("Index variable %qs redefined at %L in procedure %qs "
2387 "called from within DO loop at %L");
2388 static enum gfc_exec_op saved_io_op
;
2393 if (co
->expr1
->symtree
->n
.sym
== do_var
)
2394 gfc_error_now (errmsg
, do_var
->name
, &co
->loc
, info
->procedure
->name
,
2399 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
2400 && co
->ext
.iterator
->var
->symtree
->n
.sym
== do_var
)
2401 gfc_error (errmsg
, do_var
->name
, &co
->loc
, info
->procedure
->name
,
2408 saved_io_op
= last_io_op
;
2409 last_io_op
= co
->op
;
2413 if (co
->ext
.open
->iostat
2414 && co
->ext
.open
->iostat
->symtree
->n
.sym
== do_var
)
2415 gfc_error_now (errmsg
, do_var
->name
, &co
->ext
.open
->iostat
->where
,
2416 info
->procedure
->name
, &info
->where_do
);
2420 if (co
->ext
.close
->iostat
2421 && co
->ext
.close
->iostat
->symtree
->n
.sym
== do_var
)
2422 gfc_error_now (errmsg
, do_var
->name
, &co
->ext
.close
->iostat
->where
,
2423 info
->procedure
->name
, &info
->where_do
);
2431 #define CHECK_INQ(a) do { if (co->ext.inquire->a && \
2432 co->ext.inquire->a->symtree->n.sym == do_var) \
2433 gfc_error_now (errmsg, do_var->name, \
2434 &co->ext.inquire->a->where, \
2435 info->procedure->name, \
2441 CHECK_INQ(position
);
2443 CHECK_INQ(position
);
2444 CHECK_INQ(iolength
);
2445 CHECK_INQ(strm_pos
);
2450 if (co
->expr1
&& co
->expr1
->symtree
->n
.sym
== do_var
)
2451 gfc_error_now (errmsg
, do_var
->name
, &co
->expr1
->where
,
2452 info
->procedure
->name
, &info
->where_do
);
2457 if (co
->ext
.dt
->iostat
2458 && co
->ext
.dt
->iostat
->symtree
->n
.sym
== do_var
)
2459 gfc_error_now (errmsg
, do_var
->name
, &co
->ext
.dt
->iostat
->where
,
2460 info
->procedure
->name
, &info
->where_do
);
2469 last_io_op
= saved_io_op
;
2473 gfc_formal_arglist
*f
;
2474 gfc_actual_arglist
*a
;
2476 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2480 /* Slightly different error message here. If there is an error,
2481 return 1 to avoid an infinite loop. */
2484 if (a
->expr
&& a
->expr
->symtree
&& a
->expr
->symtree
->n
.sym
== do_var
)
2486 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2488 gfc_error_now ("Index variable %qs set to undefined as "
2489 "INTENT(OUT) argument at %L in subroutine %qs "
2490 "called from within DO loop at %L",
2491 do_var
->name
, &a
->expr
->where
,
2492 info
->procedure
->name
, &info
->where_do
);
2495 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2497 gfc_error_now ("Index variable %qs not definable as "
2498 "INTENT(INOUT) argument at %L in subroutine %qs "
2499 "called from within DO loop at %L", do_var
->name
,
2500 &a
->expr
->where
, info
->procedure
->name
,
2515 /* Callback function for code checking that we do not pass a DO variable to an
2516 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2519 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2520 void *data ATTRIBUTE_UNUSED
)
2524 gfc_formal_arglist
*f
;
2525 gfc_actual_arglist
*a
;
2532 /* If the doloop_list grew, we have to truncate it here. */
2534 if ((unsigned) doloop_level
< doloop_list
.length())
2535 doloop_list
.truncate (doloop_level
);
2542 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2547 loop
.branch_level
= if_level
+ select_level
;
2548 loop
.seen_goto
= false;
2549 doloop_list
.safe_push (loop
);
2552 /* If anything could transfer control away from a suspicious
2553 subscript, make sure to set seen_goto in the current DO loop
2558 case EXEC_ERROR_STOP
:
2564 if (co
->ext
.open
->err
)
2569 if (co
->ext
.close
->err
)
2573 case EXEC_BACKSPACE
:
2578 if (co
->ext
.filepos
->err
)
2583 if (co
->ext
.filepos
->err
)
2589 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2594 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2595 loop
.seen_goto
= true;
2599 if (co
->resolved_sym
== NULL
)
2602 /* Test if somebody stealthily changes the DO variable from
2603 under us by changing it in a host-associated procedure. */
2604 if (co
->resolved_sym
->attr
.contained
)
2606 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2608 gfc_symbol
*sym
= co
->resolved_sym
;
2609 contained_info info
;
2613 info
.do_var
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2614 info
.procedure
= co
->resolved_sym
; /* sym? */
2615 info
.where_do
= co
->loc
;
2616 /* Look contained procedures under the namespace of the
2618 for (ns
= info
.do_var
->ns
->contained
; ns
; ns
= ns
->sibling
)
2619 if (ns
->proc_name
&& ns
->proc_name
== sym
)
2620 gfc_code_walker (&ns
->code
, doloop_contained_procedure_code
,
2621 doloop_contained_function_call
, &info
);
2625 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2627 /* Withot a formal arglist, there is only unknown INTENT,
2628 which we don't check for. */
2636 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2644 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2646 if (a
->expr
&& a
->expr
->symtree
2647 && a
->expr
->symtree
->n
.sym
== do_sym
)
2649 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2650 gfc_error_now ("Variable %qs at %L set to undefined "
2651 "value inside loop beginning at %L as "
2652 "INTENT(OUT) argument to subroutine %qs",
2653 do_sym
->name
, &a
->expr
->where
,
2654 &(doloop_list
[i
].c
->loc
),
2655 co
->symtree
->n
.sym
->name
);
2656 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2657 gfc_error_now ("Variable %qs at %L not definable inside "
2658 "loop beginning at %L as INTENT(INOUT) "
2659 "argument to subroutine %qs",
2660 do_sym
->name
, &a
->expr
->where
,
2661 &(doloop_list
[i
].c
->loc
),
2662 co
->symtree
->n
.sym
->name
);
2674 if (seen_goto
&& doloop_level
> 0)
2675 doloop_list
[doloop_level
-1].seen_goto
= true;
2680 /* Callback function to warn about different things within DO loops. */
2683 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2684 void *data ATTRIBUTE_UNUSED
)
2688 if (doloop_list
.length () == 0)
2691 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2694 last
= &doloop_list
.last();
2695 if (last
->seen_goto
&& !warn_do_subscript
)
2698 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2710 /* Callback function - if the expression is the variable in data->sym,
2711 replace it with a constant from data->val. */
2714 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2721 if (ex
->expr_type
!= EXPR_VARIABLE
)
2724 d
= (insert_index_t
*) data
;
2725 if (ex
->symtree
->n
.sym
!= d
->sym
)
2728 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2729 mpz_set (n
->value
.integer
, d
->val
);
2736 /* In the expression e, replace occurrences of the variable sym with
2737 val. If this results in a constant expression, return true and
2738 return the value in ret. Return false if the expression already
2739 is a constant. Caller has to clear ret in that case. */
2742 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2745 insert_index_t data
;
2748 if (e
->expr_type
== EXPR_CONSTANT
)
2751 n
= gfc_copy_expr (e
);
2753 mpz_init_set (data
.val
, val
);
2754 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2756 /* Suppress errors here - we could get errors here such as an
2757 out of bounds access for arrays, see PR 90563. */
2758 gfc_push_suppress_errors ();
2759 gfc_simplify_expr (n
, 0);
2760 gfc_pop_suppress_errors ();
2762 if (n
->expr_type
== EXPR_CONSTANT
)
2765 mpz_init_set (ret
, n
->value
.integer
);
2770 mpz_clear (data
.val
);
2776 /* Check array subscripts for possible out-of-bounds accesses in DO
2777 loops with constant bounds. */
2780 do_subscript (gfc_expr
**e
)
2790 /* Constants are already checked. */
2791 if (v
->expr_type
== EXPR_CONSTANT
)
2794 /* Wrong warnings will be generated in an associate list. */
2798 /* We already warned about this. */
2804 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2806 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2809 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2812 mpz_t do_start
, do_step
, do_end
;
2813 bool have_do_start
, have_do_end
;
2814 bool error_not_proven
;
2822 /* If we are within a branch, or a goto or equivalent
2823 was seen in the DO loop before, then we cannot prove that
2824 this expression is actually evaluated. Don't do anything
2825 unless we want to see it all. */
2826 error_not_proven
= lp
->seen_goto
2827 || lp
->branch_level
< if_level
+ select_level
;
2829 if (error_not_proven
&& !warn_do_subscript
)
2832 if (error_not_proven
)
2833 warn
= OPT_Wdo_subscript
;
2837 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2838 if (do_sym
->ts
.type
!= BT_INTEGER
)
2841 /* If we do not know about the stepsize, the loop may be zero trip.
2842 Do not warn in this case. */
2844 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2846 sgn
= mpz_cmp_ui (dl
->ext
.iterator
->step
->value
.integer
, 0);
2847 /* This can happen, but then the error has been
2848 reported previously. */
2852 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2858 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2860 have_do_start
= true;
2861 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2864 have_do_start
= false;
2866 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2869 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2872 have_do_end
= false;
2874 if (!have_do_start
&& !have_do_end
)
2877 /* No warning inside a zero-trip loop. */
2878 if (have_do_start
&& have_do_end
)
2882 cmp
= mpz_cmp (do_end
, do_start
);
2883 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
2887 /* May have to correct the end value if the step does not equal
2889 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2895 mpz_sub (diff
, do_end
, do_start
);
2896 mpz_tdiv_r (rem
, diff
, do_step
);
2897 mpz_sub (do_end
, do_end
, rem
);
2902 for (i
= 0; i
< ar
->dimen
; i
++)
2905 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2906 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2908 if (ar
->as
->lower
[i
]
2909 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2910 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2911 gfc_warning (warn
, "Array reference at %L out of bounds "
2912 "(%ld < %ld) in loop beginning at %L",
2913 &ar
->start
[i
]->where
, mpz_get_si (val
),
2914 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2915 &doloop_list
[j
].c
->loc
);
2917 if (ar
->as
->upper
[i
]
2918 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2919 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2920 gfc_warning (warn
, "Array reference at %L out of bounds "
2921 "(%ld > %ld) in loop beginning at %L",
2922 &ar
->start
[i
]->where
, mpz_get_si (val
),
2923 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2924 &doloop_list
[j
].c
->loc
);
2929 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2930 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2932 if (ar
->as
->lower
[i
]
2933 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2934 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2935 gfc_warning (warn
, "Array reference at %L out of bounds "
2936 "(%ld < %ld) in loop beginning at %L",
2937 &ar
->start
[i
]->where
, mpz_get_si (val
),
2938 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2939 &doloop_list
[j
].c
->loc
);
2941 if (ar
->as
->upper
[i
]
2942 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2943 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2944 gfc_warning (warn
, "Array reference at %L out of bounds "
2945 "(%ld > %ld) in loop beginning at %L",
2946 &ar
->start
[i
]->where
, mpz_get_si (val
),
2947 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2948 &doloop_list
[j
].c
->loc
);
2958 /* Function for functions checking that we do not pass a DO variable
2959 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2962 do_intent (gfc_expr
**e
)
2964 gfc_formal_arglist
*f
;
2965 gfc_actual_arglist
*a
;
2973 if (expr
->expr_type
!= EXPR_FUNCTION
)
2976 /* Intrinsic functions don't modify their arguments. */
2978 if (expr
->value
.function
.isym
)
2981 sym
= expr
->value
.function
.esym
;
2985 if (sym
->attr
.contained
)
2987 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2989 contained_info info
;
2993 info
.do_var
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2994 info
.procedure
= sym
;
2995 info
.where_do
= expr
->where
;
2996 /* Look contained procedures under the namespace of the
2998 for (ns
= info
.do_var
->ns
->contained
; ns
; ns
= ns
->sibling
)
2999 if (ns
->proc_name
&& ns
->proc_name
== sym
)
3000 gfc_code_walker (&ns
->code
, doloop_contained_procedure_code
,
3001 dummy_expr_callback
, &info
);
3005 f
= gfc_sym_get_dummy_args (sym
);
3007 /* Without a formal arglist, there is only unknown INTENT,
3008 which we don't check for. */
3012 a
= expr
->value
.function
.actual
;
3016 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
3023 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
3025 if (a
->expr
&& a
->expr
->symtree
3026 && a
->expr
->symtree
->n
.sym
== do_sym
)
3028 if (f
->sym
->attr
.intent
== INTENT_OUT
)
3029 gfc_error_now ("Variable %qs at %L set to undefined value "
3030 "inside loop beginning at %L as INTENT(OUT) "
3031 "argument to function %qs", do_sym
->name
,
3032 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
3033 expr
->symtree
->n
.sym
->name
);
3034 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
3035 gfc_error_now ("Variable %qs at %L not definable inside loop"
3036 " beginning at %L as INTENT(INOUT) argument to"
3037 " function %qs", do_sym
->name
,
3038 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
3039 expr
->symtree
->n
.sym
->name
);
3050 doloop_warn (gfc_namespace
*ns
)
3052 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
3054 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
3056 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
3061 /* This selction deals with inlining calls to MATMUL. */
3063 /* Replace calls to matmul outside of straight assignments with a temporary
3064 variable so that later inlining will work. */
3067 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3071 bool *found
= (bool *) data
;
3075 if (e
->expr_type
!= EXPR_FUNCTION
3076 || e
->value
.function
.isym
== NULL
3077 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3080 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
3081 || in_omp_atomic
|| in_where
|| in_assoc_list
)
3084 /* Check if this is already in the form c = matmul(a,b). */
3086 if ((*current_code
)->expr2
== e
)
3089 n
= create_var (e
, "matmul");
3091 /* If create_var is unable to create a variable (for example if
3092 -fno-realloc-lhs is in force with a variable that does not have bounds
3093 known at compile-time), just return. */
3103 /* Set current_code and associated variables so that matmul_to_var_expr can
3107 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3108 void *data ATTRIBUTE_UNUSED
)
3110 if (current_code
!= c
)
3113 inserted_block
= NULL
;
3114 changed_statement
= NULL
;
3121 /* Take a statement of the shape c = matmul(a,b) and create temporaries
3122 for a and b if there is a dependency between the arguments and the
3123 result variable or if a or b are the result of calculations that cannot
3124 be handled by the inliner. */
3127 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3128 void *data ATTRIBUTE_UNUSED
)
3130 gfc_expr
*expr1
, *expr2
;
3132 gfc_actual_arglist
*a
, *b
;
3134 gfc_expr
*matrix_a
, *matrix_b
;
3135 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3139 if (co
->op
!= EXEC_ASSIGN
)
3142 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
3143 || in_omp_atomic
|| in_where
)
3146 /* This has some duplication with inline_matmul_assign. This
3147 is because the creation of temporary variables could still fail,
3148 and inline_matmul_assign still needs to be able to handle these
3153 if (expr2
->expr_type
!= EXPR_FUNCTION
3154 || expr2
->value
.function
.isym
== NULL
3155 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3159 a
= expr2
->value
.function
.actual
;
3160 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3161 if (matrix_a
!= NULL
)
3163 if (matrix_a
->expr_type
== EXPR_VARIABLE
3164 && (gfc_check_dependency (matrix_a
, expr1
, true)
3165 || gfc_has_dimen_vector_ref (matrix_a
)))
3173 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3174 if (matrix_b
!= NULL
)
3176 if (matrix_b
->expr_type
== EXPR_VARIABLE
3177 && (gfc_check_dependency (matrix_b
, expr1
, true)
3178 || gfc_has_dimen_vector_ref (matrix_b
)))
3184 if (!a_tmp
&& !b_tmp
)
3188 inserted_block
= NULL
;
3189 changed_statement
= NULL
;
3193 at
= create_var (a
->expr
,"mma");
3200 bt
= create_var (b
->expr
,"mmb");
3207 /* Auxiliary function to build and simplify an array inquiry function.
3208 dim is zero-based. */
3211 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
3214 gfc_expr
*dim_arg
, *kind
;
3220 case GFC_ISYM_LBOUND
:
3221 name
= "_gfortran_lbound";
3224 case GFC_ISYM_UBOUND
:
3225 name
= "_gfortran_ubound";
3229 name
= "_gfortran_size";
3236 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
3238 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3241 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
3242 gfc_index_integer_kind
);
3244 ec
= gfc_copy_expr (e
);
3246 /* No bounds checking, this will be done before the loops if -fcheck=bounds
3248 ec
->no_bounds_check
= 1;
3249 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
3251 gfc_simplify_expr (fcn
, 0);
3252 fcn
->no_bounds_check
= 1;
3256 /* Builds a logical expression. */
3259 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3264 ts
.type
= BT_LOGICAL
;
3265 ts
.kind
= gfc_default_logical_kind
;
3266 res
= gfc_get_expr ();
3267 res
->where
= e1
->where
;
3268 res
->expr_type
= EXPR_OP
;
3269 res
->value
.op
.op
= op
;
3270 res
->value
.op
.op1
= e1
;
3271 res
->value
.op
.op2
= e2
;
3278 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3279 compatible typespecs. */
3282 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3286 res
= gfc_get_expr ();
3288 res
->where
= e1
->where
;
3289 res
->expr_type
= EXPR_OP
;
3290 res
->value
.op
.op
= op
;
3291 res
->value
.op
.op1
= e1
;
3292 res
->value
.op
.op2
= e2
;
3293 gfc_simplify_expr (res
, 0);
3297 /* Generate the IF statement for a runtime check if we want to do inlining or
3298 not - putting in the code for both branches and putting it into the syntax
3299 tree is the caller's responsibility. For fixed array sizes, this should be
3300 removed by DCE. Only called for rank-two matrices A and B. */
3303 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3305 gfc_expr
*inline_limit
;
3306 gfc_code
*if_1
, *if_2
, *else_2
;
3307 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3311 /* Calculation is done in real to avoid integer overflow. */
3313 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3315 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3316 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3319 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3320 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3321 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3325 ts
.kind
= gfc_default_real_kind
;
3326 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3327 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3328 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3330 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3331 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3333 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3334 gfc_simplify_expr (cond
, 0);
3336 else_2
= XCNEW (gfc_code
);
3337 else_2
->op
= EXEC_IF
;
3338 else_2
->loc
= a
->where
;
3340 if_2
= XCNEW (gfc_code
);
3343 if_2
->loc
= a
->where
;
3344 if_2
->block
= else_2
;
3346 if_1
= XCNEW (gfc_code
);
3349 if_1
->loc
= a
->where
;
3355 /* Insert code to issue a runtime error if the expressions are not equal. */
3358 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3361 gfc_code
*if_1
, *if_2
;
3363 gfc_actual_arglist
*a1
, *a2
, *a3
;
3365 gcc_assert (e1
->where
.lb
);
3366 /* Build the call to runtime_error. */
3367 c
= XCNEW (gfc_code
);
3371 /* Get a null-terminated message string. */
3373 a1
= gfc_get_actual_arglist ();
3374 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3375 msg
, strlen(msg
)+1);
3378 /* Pass the value of the first expression. */
3379 a2
= gfc_get_actual_arglist ();
3380 a2
->expr
= gfc_copy_expr (e1
);
3383 /* Pass the value of the second expression. */
3384 a3
= gfc_get_actual_arglist ();
3385 a3
->expr
= gfc_copy_expr (e2
);
3388 gfc_check_fe_runtime_error (c
->ext
.actual
);
3389 gfc_resolve_fe_runtime_error (c
);
3391 if_2
= XCNEW (gfc_code
);
3393 if_2
->loc
= e1
->where
;
3396 if_1
= XCNEW (gfc_code
);
3399 if_1
->loc
= e1
->where
;
3401 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3402 gfc_simplify_expr (cond
, 0);
3408 /* Handle matrix reallocation. Caller is responsible to insert into
3411 For the two-dimensional case, build
3413 if (allocated(c)) then
3414 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3416 allocate (c(size(a,1), size(b,2)))
3419 allocate (c(size(a,1),size(b,2)))
3422 and for the other cases correspondingly.
3426 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3427 enum matrix_case m_case
)
3430 gfc_expr
*allocated
, *alloc_expr
;
3431 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3432 gfc_code
*else_alloc
;
3433 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3435 gfc_expr
*cond
, *ne1
, *ne2
;
3437 if (warn_realloc_lhs
)
3438 gfc_warning (OPT_Wrealloc_lhs
,
3439 "Code for reallocating the allocatable array at %L will "
3440 "be added", &c
->where
);
3442 alloc_expr
= gfc_copy_expr (c
);
3444 ar
= gfc_find_array_ref (alloc_expr
);
3445 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3447 /* c comes in as a full ref. Change it into a copy and make it into an
3448 element ref so it has the right form for ALLOCATE. In the same
3449 switch statement, also generate the size comparison for the secod IF
3452 ar
->type
= AR_ELEMENT
;
3457 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3458 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3459 ne1
= build_logical_expr (INTRINSIC_NE
,
3460 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3461 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3462 ne2
= build_logical_expr (INTRINSIC_NE
,
3463 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3464 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3465 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3469 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3470 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3472 ne1
= build_logical_expr (INTRINSIC_NE
,
3473 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3474 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3475 ne2
= build_logical_expr (INTRINSIC_NE
,
3476 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3477 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3478 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3483 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3484 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3486 ne1
= build_logical_expr (INTRINSIC_NE
,
3487 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3488 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3489 ne2
= build_logical_expr (INTRINSIC_NE
,
3490 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3491 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3492 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3496 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3497 cond
= build_logical_expr (INTRINSIC_NE
,
3498 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3499 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3503 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3504 cond
= build_logical_expr (INTRINSIC_NE
,
3505 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3506 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3510 /* This can only happen for BLAS, we do not handle that case in
3512 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3513 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3515 ne1
= build_logical_expr (INTRINSIC_NE
,
3516 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3517 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3518 ne2
= build_logical_expr (INTRINSIC_NE
,
3519 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3520 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3522 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3530 gfc_simplify_expr (cond
, 0);
3532 /* We need two identical allocate statements in two
3533 branches of the IF statement. */
3535 allocate1
= XCNEW (gfc_code
);
3536 allocate1
->op
= EXEC_ALLOCATE
;
3537 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3538 allocate1
->loc
= c
->where
;
3539 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3541 allocate_else
= XCNEW (gfc_code
);
3542 allocate_else
->op
= EXEC_ALLOCATE
;
3543 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3544 allocate_else
->loc
= c
->where
;
3545 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3547 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3548 "_gfortran_allocated", c
->where
,
3549 1, gfc_copy_expr (c
));
3551 deallocate
= XCNEW (gfc_code
);
3552 deallocate
->op
= EXEC_DEALLOCATE
;
3553 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3554 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3555 deallocate
->next
= allocate1
;
3556 deallocate
->loc
= c
->where
;
3558 if_size_2
= XCNEW (gfc_code
);
3559 if_size_2
->op
= EXEC_IF
;
3560 if_size_2
->expr1
= cond
;
3561 if_size_2
->loc
= c
->where
;
3562 if_size_2
->next
= deallocate
;
3564 if_size_1
= XCNEW (gfc_code
);
3565 if_size_1
->op
= EXEC_IF
;
3566 if_size_1
->block
= if_size_2
;
3567 if_size_1
->loc
= c
->where
;
3569 else_alloc
= XCNEW (gfc_code
);
3570 else_alloc
->op
= EXEC_IF
;
3571 else_alloc
->loc
= c
->where
;
3572 else_alloc
->next
= allocate_else
;
3574 if_alloc_2
= XCNEW (gfc_code
);
3575 if_alloc_2
->op
= EXEC_IF
;
3576 if_alloc_2
->expr1
= allocated
;
3577 if_alloc_2
->loc
= c
->where
;
3578 if_alloc_2
->next
= if_size_1
;
3579 if_alloc_2
->block
= else_alloc
;
3581 if_alloc_1
= XCNEW (gfc_code
);
3582 if_alloc_1
->op
= EXEC_IF
;
3583 if_alloc_1
->block
= if_alloc_2
;
3584 if_alloc_1
->loc
= c
->where
;
3589 /* Callback function for has_function_or_op. */
3592 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3593 void *data ATTRIBUTE_UNUSED
)
3598 return (*e
)->expr_type
== EXPR_FUNCTION
3599 || (*e
)->expr_type
== EXPR_OP
;
3602 /* Returns true if the expression contains a function. */
3605 has_function_or_op (gfc_expr
**e
)
3610 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3613 /* Freeze (assign to a temporary variable) a single expression. */
3616 freeze_expr (gfc_expr
**ep
)
3619 if (has_function_or_op (ep
))
3621 ne
= create_var (*ep
, "freeze");
3626 /* Go through an expression's references and assign them to temporary
3627 variables if they contain functions. This is usually done prior to
3628 front-end scalarization to avoid multiple invocations of functions. */
3631 freeze_references (gfc_expr
*e
)
3637 for (r
=e
->ref
; r
; r
=r
->next
)
3639 if (r
->type
== REF_SUBSTRING
)
3641 if (r
->u
.ss
.start
!= NULL
)
3642 freeze_expr (&r
->u
.ss
.start
);
3644 if (r
->u
.ss
.end
!= NULL
)
3645 freeze_expr (&r
->u
.ss
.end
);
3647 else if (r
->type
== REF_ARRAY
)
3656 for (i
=0; i
<ar
->dimen
; i
++)
3658 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3660 freeze_expr (&ar
->start
[i
]);
3661 freeze_expr (&ar
->end
[i
]);
3662 freeze_expr (&ar
->stride
[i
]);
3664 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3666 freeze_expr (&ar
->start
[i
]);
3672 for (i
=0; i
<ar
->dimen
; i
++)
3673 freeze_expr (&ar
->start
[i
]);
3683 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3686 convert_to_index_kind (gfc_expr
*e
)
3690 gcc_assert (e
!= NULL
);
3692 res
= gfc_copy_expr (e
);
3694 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3696 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3700 ts
.type
= BT_INTEGER
;
3701 ts
.kind
= gfc_index_integer_kind
;
3703 gfc_convert_type_warn (e
, &ts
, 2, 0);
3709 /* Function to create a DO loop including creation of the
3710 iteration variable. gfc_expr are copied.*/
3713 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3714 gfc_namespace
*ns
, char *vname
)
3717 char name
[GFC_MAX_SYMBOL_LEN
+1];
3718 gfc_symtree
*symtree
;
3723 /* Create an expression for the iteration variable. */
3725 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3727 sprintf (name
, "__var_%d_do", var_num
++);
3730 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3733 /* Create the loop variable. */
3735 symbol
= symtree
->n
.sym
;
3736 symbol
->ts
.type
= BT_INTEGER
;
3737 symbol
->ts
.kind
= gfc_index_integer_kind
;
3738 symbol
->attr
.flavor
= FL_VARIABLE
;
3739 symbol
->attr
.referenced
= 1;
3740 symbol
->attr
.dimension
= 0;
3741 symbol
->attr
.fe_temp
= 1;
3742 gfc_commit_symbol (symbol
);
3744 i
= gfc_get_expr ();
3745 i
->expr_type
= EXPR_VARIABLE
;
3749 i
->symtree
= symtree
;
3751 /* ... and the nested DO statements. */
3752 n
= XCNEW (gfc_code
);
3755 n
->ext
.iterator
= gfc_get_iterator ();
3756 n
->ext
.iterator
->var
= i
;
3757 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3758 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3760 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3762 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3765 n2
= XCNEW (gfc_code
);
3773 /* Get the upper bound of the DO loops for matmul along a dimension. This
3777 get_size_m1 (gfc_expr
*e
, int dimen
)
3782 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3784 res
= gfc_get_constant_expr (BT_INTEGER
,
3785 gfc_index_integer_kind
, &e
->where
);
3786 mpz_sub_ui (res
->value
.integer
, size
, 1);
3791 res
= get_operand (INTRINSIC_MINUS
,
3792 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3793 gfc_get_int_expr (gfc_index_integer_kind
,
3795 gfc_simplify_expr (res
, 0);
3801 /* Function to return a scalarized expression. It is assumed that indices are
3802 zero based to make generation of DO loops easier. A zero as index will
3803 access the first element along a dimension. Single element references will
3804 be skipped. A NULL as an expression will be replaced by a full reference.
3805 This assumes that the index loops have gfc_index_integer_kind, and that all
3806 references have been frozen. */
3809 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3818 e
= gfc_copy_expr(e_in
);
3822 ar
= gfc_find_array_ref (e
);
3824 /* We scalarize count_index variables, reducing the rank by count_index. */
3826 e
->rank
= rank
- count_index
;
3828 was_fullref
= ar
->type
== AR_FULL
;
3831 ar
->type
= AR_ELEMENT
;
3833 ar
->type
= AR_SECTION
;
3835 /* Loop over the indices. For each index, create the expression
3836 index * stride + lbound(e, dim). */
3839 for (i
=0; i
< ar
->dimen
; i
++)
3841 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3843 if (index
[i_index
] != NULL
)
3845 gfc_expr
*lbound
, *nindex
;
3848 loopvar
= gfc_copy_expr (index
[i_index
]);
3854 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3855 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3859 ts
.type
= BT_INTEGER
;
3860 ts
.kind
= gfc_index_integer_kind
;
3861 gfc_convert_type (tmp
, &ts
, 2);
3863 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3868 /* Calculate the lower bound of the expression. */
3871 lbound
= gfc_copy_expr (ar
->start
[i
]);
3872 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3876 ts
.type
= BT_INTEGER
;
3877 ts
.kind
= gfc_index_integer_kind
;
3878 gfc_convert_type (lbound
, &ts
, 2);
3887 lbound_e
= gfc_copy_expr (e_in
);
3889 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3890 if (ref
->type
== REF_ARRAY
3891 && (ref
->u
.ar
.type
== AR_FULL
3892 || ref
->u
.ar
.type
== AR_SECTION
))
3897 gfc_free_ref_list (ref
->next
);
3903 /* Look at full individual sections, like a(:). The first index
3904 is the lbound of a full ref. */
3911 /* For assumed size, we need to keep around the final
3912 reference in order not to get an error on resolution
3913 below, and we cannot use AR_FULL. */
3915 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3917 ar
->type
= AR_SECTION
;
3926 for (j
= 0; j
< to
; j
++)
3928 gfc_free_expr (ar
->start
[j
]);
3929 ar
->start
[j
] = NULL
;
3930 gfc_free_expr (ar
->end
[j
]);
3932 gfc_free_expr (ar
->stride
[j
]);
3933 ar
->stride
[j
] = NULL
;
3936 /* We have to get rid of the shape, if there is one. Do
3937 so by freeing it and calling gfc_resolve to rebuild
3938 it, if necessary. */
3940 if (lbound_e
->shape
)
3941 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3943 lbound_e
->rank
= ar
->dimen
;
3944 gfc_resolve_expr (lbound_e
);
3946 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3948 gfc_free_expr (lbound_e
);
3951 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3953 gfc_free_expr (ar
->start
[i
]);
3954 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3956 gfc_free_expr (ar
->end
[i
]);
3958 gfc_free_expr (ar
->stride
[i
]);
3959 ar
->stride
[i
] = NULL
;
3960 gfc_simplify_expr (ar
->start
[i
], 0);
3962 else if (was_fullref
)
3964 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3970 /* Bounds checking will be done before the loops if -fcheck=bounds
3972 e
->no_bounds_check
= 1;
3976 /* Helper function to check for a dimen vector as subscript. */
3979 gfc_has_dimen_vector_ref (gfc_expr
*e
)
3984 ar
= gfc_find_array_ref (e
);
3986 if (ar
->type
== AR_FULL
)
3989 for (i
=0; i
<ar
->dimen
; i
++)
3990 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3996 /* If handed an expression of the form
4000 check if A can be handled by matmul and return if there is an uneven number
4001 of CONJG calls. Return a pointer to the array when everything is OK, NULL
4002 otherwise. The caller has to check for the correct rank. */
4005 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
4012 if (e
->expr_type
== EXPR_VARIABLE
)
4014 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
4017 else if (e
->expr_type
== EXPR_FUNCTION
)
4019 if (e
->value
.function
.isym
== NULL
)
4022 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
4024 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
4025 *transpose
= !*transpose
;
4031 e
= e
->value
.function
.actual
->expr
;
4038 /* Macros for unified error messages. */
4040 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
4041 "dimension 1: is %ld, should be %ld")
4043 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
4046 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
4050 /* Inline assignments of the form c = matmul(a,b).
4051 Handle only the cases currently where b and c are rank-two arrays.
4053 This basically translates the code to
4059 do k=0, size(a, 2)-1
4060 do i=0, size(a, 1)-1
4061 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
4062 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
4063 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
4064 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
4073 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
4074 void *data ATTRIBUTE_UNUSED
)
4077 gfc_expr
*expr1
, *expr2
;
4078 gfc_expr
*matrix_a
, *matrix_b
;
4079 gfc_actual_arglist
*a
, *b
;
4080 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
4082 gfc_expr
*u1
, *u2
, *u3
;
4084 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
4086 gfc_expr
*var_1
, *var_2
, *var_3
;
4089 gfc_intrinsic_op op_times
, op_plus
;
4090 enum matrix_case m_case
;
4092 gfc_code
*if_limit
= NULL
;
4093 gfc_code
**next_code_point
;
4094 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4097 if (co
->op
!= EXEC_ASSIGN
)
4100 if (in_where
|| in_assoc_list
)
4103 /* The BLOCKS generated for the temporary variables and FORALL don't
4105 if (forall_level
> 0)
4108 /* For now don't do anything in OpenMP workshare, it confuses
4109 its translation, which expects only the allowed statements in there.
4110 We should figure out how to parallelize this eventually. */
4111 if (in_omp_workshare
|| in_omp_atomic
)
4116 if (expr2
->expr_type
!= EXPR_FUNCTION
4117 || expr2
->value
.function
.isym
== NULL
4118 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4122 inserted_block
= NULL
;
4123 changed_statement
= NULL
;
4125 a
= expr2
->value
.function
.actual
;
4126 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4127 if (matrix_a
== NULL
)
4131 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4132 if (matrix_b
== NULL
)
4135 if (gfc_has_dimen_vector_ref (expr1
) || gfc_has_dimen_vector_ref (matrix_a
)
4136 || gfc_has_dimen_vector_ref (matrix_b
))
4139 /* We do not handle data dependencies yet. */
4140 if (gfc_check_dependency (expr1
, matrix_a
, true)
4141 || gfc_check_dependency (expr1
, matrix_b
, true))
4145 if (matrix_a
->rank
== 2)
4149 if (matrix_b
->rank
== 2 && !transpose_b
)
4154 if (matrix_b
->rank
== 1)
4156 else /* matrix_b->rank == 2 */
4165 else /* matrix_a->rank == 1 */
4167 if (matrix_b
->rank
== 2)
4177 ns
= insert_block ();
4179 /* Assign the type of the zero expression for initializing the resulting
4180 array, and the expression (+ and * for real, integer and complex;
4181 .and. and .or for logical. */
4183 switch(expr1
->ts
.type
)
4186 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
4187 op_times
= INTRINSIC_TIMES
;
4188 op_plus
= INTRINSIC_PLUS
;
4192 op_times
= INTRINSIC_AND
;
4193 op_plus
= INTRINSIC_OR
;
4194 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
4198 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
4200 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
4201 op_times
= INTRINSIC_TIMES
;
4202 op_plus
= INTRINSIC_PLUS
;
4206 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
4208 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
4209 op_times
= INTRINSIC_TIMES
;
4210 op_plus
= INTRINSIC_PLUS
;
4218 current_code
= &ns
->code
;
4220 /* Freeze the references, keeping track of how many temporary variables were
4223 freeze_references (matrix_a
);
4224 freeze_references (matrix_b
);
4225 freeze_references (expr1
);
4228 next_code_point
= current_code
;
4231 next_code_point
= &ns
->code
;
4232 for (i
=0; i
<n_vars
; i
++)
4233 next_code_point
= &(*next_code_point
)->next
;
4236 /* Take care of the inline flag. If the limit check evaluates to a
4237 constant, dead code elimination will eliminate the unneeded branch. */
4239 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
4240 && matrix_b
->rank
== 2)
4242 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
4243 flag_inline_matmul_limit
);
4245 /* Insert the original statement into the else branch. */
4246 if_limit
->block
->block
->next
= co
;
4249 /* ... and the new ones go into the original one. */
4250 *next_code_point
= if_limit
;
4251 next_code_point
= &if_limit
->block
->next
;
4254 zero_e
->no_bounds_check
= 1;
4256 assign_zero
= XCNEW (gfc_code
);
4257 assign_zero
->op
= EXEC_ASSIGN
;
4258 assign_zero
->loc
= co
->loc
;
4259 assign_zero
->expr1
= gfc_copy_expr (expr1
);
4260 assign_zero
->expr1
->no_bounds_check
= 1;
4261 assign_zero
->expr2
= zero_e
;
4263 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4265 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4268 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
4274 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4275 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4276 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4277 *next_code_point
= test
;
4278 next_code_point
= &test
->next
;
4282 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4283 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4284 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4285 *next_code_point
= test
;
4286 next_code_point
= &test
->next
;
4292 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4293 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4294 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4295 *next_code_point
= test
;
4296 next_code_point
= &test
->next
;
4300 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4301 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4302 test
= runtime_error_ne (c1
, b2
, C_ERROR_1
);
4303 *next_code_point
= test
;
4304 next_code_point
= &test
->next
;
4310 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4311 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4312 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4313 *next_code_point
= test
;
4314 next_code_point
= &test
->next
;
4318 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4319 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4320 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4321 *next_code_point
= test
;
4322 next_code_point
= &test
->next
;
4324 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4325 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4326 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4327 *next_code_point
= test
;
4328 next_code_point
= &test
->next
;
4334 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4335 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4336 /* matrix_b is transposed, hence dimension 1 for the error message. */
4337 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4338 *next_code_point
= test
;
4339 next_code_point
= &test
->next
;
4343 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4344 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4345 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4346 *next_code_point
= test
;
4347 next_code_point
= &test
->next
;
4349 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4350 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4351 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4352 *next_code_point
= test
;
4353 next_code_point
= &test
->next
;
4359 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4360 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4361 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4362 *next_code_point
= test
;
4363 next_code_point
= &test
->next
;
4367 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4368 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4369 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4370 *next_code_point
= test
;
4371 next_code_point
= &test
->next
;
4373 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4374 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4375 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4376 *next_code_point
= test
;
4377 next_code_point
= &test
->next
;
4386 /* Handle the reallocation, if needed. */
4390 gfc_code
*lhs_alloc
;
4392 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4394 *next_code_point
= lhs_alloc
;
4395 next_code_point
= &lhs_alloc
->next
;
4399 *next_code_point
= assign_zero
;
4401 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4403 assign_matmul
= XCNEW (gfc_code
);
4404 assign_matmul
->op
= EXEC_ASSIGN
;
4405 assign_matmul
->loc
= co
->loc
;
4407 /* Get the bounds for the loops, create them and create the scalarized
4414 u1
= get_size_m1 (matrix_b
, 2);
4415 u2
= get_size_m1 (matrix_a
, 2);
4416 u3
= get_size_m1 (matrix_a
, 1);
4418 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4419 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4420 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4422 do_1
->block
->next
= do_2
;
4423 do_2
->block
->next
= do_3
;
4424 do_3
->block
->next
= assign_matmul
;
4426 var_1
= do_1
->ext
.iterator
->var
;
4427 var_2
= do_2
->ext
.iterator
->var
;
4428 var_3
= do_3
->ext
.iterator
->var
;
4432 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4436 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4440 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4446 u1
= get_size_m1 (matrix_b
, 1);
4447 u2
= get_size_m1 (matrix_a
, 2);
4448 u3
= get_size_m1 (matrix_a
, 1);
4450 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4451 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4452 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4454 do_1
->block
->next
= do_2
;
4455 do_2
->block
->next
= do_3
;
4456 do_3
->block
->next
= assign_matmul
;
4458 var_1
= do_1
->ext
.iterator
->var
;
4459 var_2
= do_2
->ext
.iterator
->var
;
4460 var_3
= do_3
->ext
.iterator
->var
;
4464 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4468 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4472 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4478 u1
= get_size_m1 (matrix_a
, 2);
4479 u2
= get_size_m1 (matrix_b
, 2);
4480 u3
= get_size_m1 (matrix_a
, 1);
4482 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4483 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4484 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4486 do_1
->block
->next
= do_2
;
4487 do_2
->block
->next
= do_3
;
4488 do_3
->block
->next
= assign_matmul
;
4490 var_1
= do_1
->ext
.iterator
->var
;
4491 var_2
= do_2
->ext
.iterator
->var
;
4492 var_3
= do_3
->ext
.iterator
->var
;
4496 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4500 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4504 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4509 u1
= get_size_m1 (matrix_b
, 1);
4510 u2
= get_size_m1 (matrix_a
, 1);
4512 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4513 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4515 do_1
->block
->next
= do_2
;
4516 do_2
->block
->next
= assign_matmul
;
4518 var_1
= do_1
->ext
.iterator
->var
;
4519 var_2
= do_2
->ext
.iterator
->var
;
4522 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4526 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4529 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4534 u1
= get_size_m1 (matrix_b
, 2);
4535 u2
= get_size_m1 (matrix_a
, 1);
4537 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4538 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4540 do_1
->block
->next
= do_2
;
4541 do_2
->block
->next
= assign_matmul
;
4543 var_1
= do_1
->ext
.iterator
->var
;
4544 var_2
= do_2
->ext
.iterator
->var
;
4547 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4550 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4554 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4562 /* Build the conjg call around the variables. Set the typespec manually
4563 because gfc_build_intrinsic_call sometimes gets this wrong. */
4568 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4569 matrix_a
->where
, 1, ascalar
);
4577 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4578 matrix_b
->where
, 1, bscalar
);
4581 /* First loop comes after the zero assignment. */
4582 assign_zero
->next
= do_1
;
4584 /* Build the assignment expression in the loop. */
4585 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4587 mult
= get_operand (op_times
, ascalar
, bscalar
);
4588 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4590 /* If we don't want to keep the original statement around in
4591 the else branch, we can free it. */
4593 if (if_limit
== NULL
)
4594 gfc_free_statements(co
);
4598 gfc_free_expr (zero
);
4603 /* Change matmul function calls in the form of
4607 to the corresponding call to a BLAS routine, if applicable. */
4610 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4611 void *data ATTRIBUTE_UNUSED
)
4613 gfc_code
*co
, *co_next
;
4614 gfc_expr
*expr1
, *expr2
;
4615 gfc_expr
*matrix_a
, *matrix_b
;
4616 gfc_code
*if_limit
= NULL
;
4617 gfc_actual_arglist
*a
, *b
;
4618 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4620 const char *blas_name
;
4621 const char *transa
, *transb
;
4622 gfc_expr
*c1
, *c2
, *b1
;
4623 gfc_actual_arglist
*actual
, *next
;
4626 enum matrix_case m_case
;
4628 gfc_code
**next_code_point
;
4630 /* Many of the tests for inline matmul also apply here. */
4634 if (co
->op
!= EXEC_ASSIGN
)
4637 if (in_where
|| in_assoc_list
)
4640 /* The BLOCKS generated for the temporary variables and FORALL don't
4642 if (forall_level
> 0)
4645 /* For now don't do anything in OpenMP workshare, it confuses
4646 its translation, which expects only the allowed statements in there. */
4648 if (in_omp_workshare
|| in_omp_atomic
)
4653 if (expr2
->expr_type
!= EXPR_FUNCTION
4654 || expr2
->value
.function
.isym
== NULL
4655 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4658 type
= expr2
->ts
.type
;
4659 kind
= expr2
->ts
.kind
;
4661 /* Guard against recursion. */
4663 if (expr2
->external_blas
)
4666 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4669 if (type
== BT_REAL
)
4672 blas_name
= "sgemm";
4674 blas_name
= "dgemm";
4678 else if (type
== BT_COMPLEX
)
4681 blas_name
= "cgemm";
4683 blas_name
= "zgemm";
4690 a
= expr2
->value
.function
.actual
;
4691 if (a
->expr
->rank
!= 2)
4695 if (b
->expr
->rank
!= 2)
4698 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4699 if (matrix_a
== NULL
)
4712 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4713 if (matrix_b
== NULL
)
4742 inserted_block
= NULL
;
4743 changed_statement
= NULL
;
4745 expr2
->external_blas
= 1;
4747 /* We do not handle data dependencies yet. */
4748 if (gfc_check_dependency (expr1
, matrix_a
, true)
4749 || gfc_check_dependency (expr1
, matrix_b
, true))
4752 /* Generate the if statement and hang it into the tree. */
4753 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4755 (*current_code
) = if_limit
;
4757 if_limit
->block
->next
= co
;
4759 call
= XCNEW (gfc_code
);
4760 call
->loc
= co
->loc
;
4762 /* Bounds checking - a bit simpler than for inlining since we only
4763 have to take care of two-dimensional arrays here. */
4765 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4766 next_code_point
= &(if_limit
->block
->block
->next
);
4768 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4771 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4772 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4776 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4777 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4778 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4779 *next_code_point
= test
;
4780 next_code_point
= &test
->next
;
4784 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4785 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4786 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4787 *next_code_point
= test
;
4788 next_code_point
= &test
->next
;
4790 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4791 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4792 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4793 *next_code_point
= test
;
4794 next_code_point
= &test
->next
;
4800 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4801 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4802 /* matrix_b is transposed, hence dimension 1 for the error message. */
4803 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4804 *next_code_point
= test
;
4805 next_code_point
= &test
->next
;
4809 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4810 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4811 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4812 *next_code_point
= test
;
4813 next_code_point
= &test
->next
;
4815 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4816 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4817 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4818 *next_code_point
= test
;
4819 next_code_point
= &test
->next
;
4825 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4826 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4827 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4828 *next_code_point
= test
;
4829 next_code_point
= &test
->next
;
4833 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4834 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4835 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4836 *next_code_point
= test
;
4837 next_code_point
= &test
->next
;
4839 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4840 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4841 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4842 *next_code_point
= test
;
4843 next_code_point
= &test
->next
;
4848 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4849 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4850 test
= runtime_error_ne (b2
, a1
, B_ERROR_1
);
4851 *next_code_point
= test
;
4852 next_code_point
= &test
->next
;
4856 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4857 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4858 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4859 *next_code_point
= test
;
4860 next_code_point
= &test
->next
;
4862 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4863 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4864 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4865 *next_code_point
= test
;
4866 next_code_point
= &test
->next
;
4875 /* Handle the reallocation, if needed. */
4879 gfc_code
*lhs_alloc
;
4881 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4882 *next_code_point
= lhs_alloc
;
4883 next_code_point
= &lhs_alloc
->next
;
4886 *next_code_point
= call
;
4887 if_limit
->next
= co_next
;
4889 /* Set up the BLAS call. */
4891 call
->op
= EXEC_CALL
;
4893 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4894 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4895 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4896 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4897 call
->resolved_sym
= call
->symtree
->n
.sym
;
4898 gfc_commit_symbol (call
->resolved_sym
);
4900 /* Argument TRANSA. */
4901 next
= gfc_get_actual_arglist ();
4902 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4905 call
->ext
.actual
= next
;
4907 /* Argument TRANSB. */
4909 next
= gfc_get_actual_arglist ();
4910 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4912 actual
->next
= next
;
4914 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4915 gfc_integer_4_kind
);
4916 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4917 gfc_integer_4_kind
);
4919 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4920 gfc_integer_4_kind
);
4924 next
= gfc_get_actual_arglist ();
4926 actual
->next
= next
;
4930 next
= gfc_get_actual_arglist ();
4932 actual
->next
= next
;
4936 next
= gfc_get_actual_arglist ();
4938 actual
->next
= next
;
4940 /* Argument ALPHA - set to one. */
4942 next
= gfc_get_actual_arglist ();
4943 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4944 if (type
== BT_REAL
)
4945 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4947 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4948 actual
->next
= next
;
4952 next
= gfc_get_actual_arglist ();
4953 next
->expr
= gfc_copy_expr (matrix_a
);
4954 actual
->next
= next
;
4958 next
= gfc_get_actual_arglist ();
4959 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4960 1, gfc_integer_4_kind
);
4961 actual
->next
= next
;
4965 next
= gfc_get_actual_arglist ();
4966 next
->expr
= gfc_copy_expr (matrix_b
);
4967 actual
->next
= next
;
4971 next
= gfc_get_actual_arglist ();
4972 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4973 1, gfc_integer_4_kind
);
4974 actual
->next
= next
;
4976 /* Argument BETA - set to zero. */
4978 next
= gfc_get_actual_arglist ();
4979 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4980 if (type
== BT_REAL
)
4981 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4983 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4984 actual
->next
= next
;
4989 next
= gfc_get_actual_arglist ();
4990 next
->expr
= gfc_copy_expr (expr1
);
4991 actual
->next
= next
;
4995 next
= gfc_get_actual_arglist ();
4996 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4997 1, gfc_integer_4_kind
);
4998 actual
->next
= next
;
5004 /* Code for index interchange for loops which are grouped together in DO
5005 CONCURRENT or FORALL statements. This is currently only applied if the
5006 iterations are grouped together in a single statement.
5008 For this transformation, it is assumed that memory access in strides is
5009 expensive, and that loops which access later indices (which access memory
5010 in bigger strides) should be moved to the first loops.
5012 For this, a loop over all the statements is executed, counting the times
5013 that the loop iteration values are accessed in each index. The loop
5014 indices are then sorted to minimize access to later indices from inner
5017 /* Type for holding index information. */
5021 gfc_forall_iterator
*fa
;
5023 int n
[GFC_MAX_DIMENSIONS
];
5026 /* Callback function to determine if an expression is the
5027 corresponding variable. */
5030 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
5032 gfc_expr
*expr
= *e
;
5035 if (expr
->expr_type
!= EXPR_VARIABLE
)
5038 sym
= (gfc_symbol
*) data
;
5039 return sym
== expr
->symtree
->n
.sym
;
5042 /* Callback function to calculate the cost of a certain index. */
5045 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5055 if (expr
->expr_type
!= EXPR_VARIABLE
)
5059 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
5061 if (ref
->type
== REF_ARRAY
)
5067 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
5070 ind
= (ind_type
*) data
;
5071 for (i
= 0; i
< ar
->dimen
; i
++)
5073 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
5075 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
5082 /* Callback function for qsort, to sort the loop indices. */
5085 loop_comp (const void *e1
, const void *e2
)
5087 const ind_type
*i1
= (const ind_type
*) e1
;
5088 const ind_type
*i2
= (const ind_type
*) e2
;
5091 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
5093 if (i1
->n
[i
] != i2
->n
[i
])
5094 return i1
->n
[i
] - i2
->n
[i
];
5096 /* All other things being equal, let's not change the ordering. */
5097 return i2
->num
- i1
->num
;
5100 /* Main function to do the index interchange. */
5103 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5104 void *data ATTRIBUTE_UNUSED
)
5109 gfc_forall_iterator
*fa
;
5113 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
5117 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5120 /* Nothing to reorder. */
5124 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
5127 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5129 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
5131 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
5136 ind
[n_iter
].sym
= NULL
;
5137 ind
[n_iter
].fa
= NULL
;
5139 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
5140 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
5142 /* Do the actual index interchange. */
5143 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
5144 for (i
=1; i
<n_iter
; i
++)
5146 fa
->next
= ind
[i
].fa
;
5151 if (flag_warn_frontend_loop_interchange
)
5153 for (i
=1; i
<n_iter
; i
++)
5155 if (ind
[i
-1].num
> ind
[i
].num
)
5157 gfc_warning (OPT_Wfrontend_loop_interchange
,
5158 "Interchanging loops at %L", &co
->loc
);
5167 #define WALK_SUBEXPR(NODE) \
5170 result = gfc_expr_walker (&(NODE), exprfn, data); \
5175 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
5177 /* Walk expression *E, calling EXPRFN on each expression in it. */
5180 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
5184 int walk_subtrees
= 1;
5185 gfc_actual_arglist
*a
;
5189 int result
= exprfn (e
, &walk_subtrees
, data
);
5193 switch ((*e
)->expr_type
)
5196 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
5197 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
5200 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
5201 WALK_SUBEXPR (a
->expr
);
5205 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
5206 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
5207 WALK_SUBEXPR (a
->expr
);
5210 case EXPR_STRUCTURE
:
5212 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
5213 c
= gfc_constructor_next (c
))
5215 if (c
->iterator
== NULL
)
5216 WALK_SUBEXPR (c
->expr
);
5220 WALK_SUBEXPR (c
->expr
);
5222 WALK_SUBEXPR (c
->iterator
->var
);
5223 WALK_SUBEXPR (c
->iterator
->start
);
5224 WALK_SUBEXPR (c
->iterator
->end
);
5225 WALK_SUBEXPR (c
->iterator
->step
);
5229 if ((*e
)->expr_type
!= EXPR_ARRAY
)
5232 /* Fall through to the variable case in order to walk the
5236 case EXPR_SUBSTRING
:
5238 for (r
= (*e
)->ref
; r
; r
= r
->next
)
5247 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
5249 for (i
=0; i
< ar
->dimen
; i
++)
5251 WALK_SUBEXPR (ar
->start
[i
]);
5252 WALK_SUBEXPR (ar
->end
[i
]);
5253 WALK_SUBEXPR (ar
->stride
[i
]);
5260 WALK_SUBEXPR (r
->u
.ss
.start
);
5261 WALK_SUBEXPR (r
->u
.ss
.end
);
5278 #define WALK_SUBCODE(NODE) \
5281 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5287 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5288 on each expression in it. If any of the hooks returns non-zero, that
5289 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5290 no subcodes or subexpressions are traversed. */
5293 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5296 for (; *c
; c
= &(*c
)->next
)
5298 int walk_subtrees
= 1;
5299 int result
= codefn (c
, &walk_subtrees
, data
);
5306 gfc_actual_arglist
*a
;
5308 gfc_association_list
*alist
;
5309 bool saved_in_omp_workshare
;
5310 bool saved_in_omp_atomic
;
5311 bool saved_in_where
;
5313 /* There might be statement insertions before the current code,
5314 which must not affect the expression walker. */
5317 saved_in_omp_workshare
= in_omp_workshare
;
5318 saved_in_omp_atomic
= in_omp_atomic
;
5319 saved_in_where
= in_where
;
5325 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5326 if (co
->ext
.block
.assoc
)
5328 bool saved_in_assoc_list
= in_assoc_list
;
5330 in_assoc_list
= true;
5331 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5332 WALK_SUBEXPR (alist
->target
);
5334 in_assoc_list
= saved_in_assoc_list
;
5341 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5342 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5343 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5344 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5356 case EXEC_ASSIGN_CALL
:
5357 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5358 WALK_SUBEXPR (a
->expr
);
5362 WALK_SUBEXPR (co
->expr1
);
5363 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5364 WALK_SUBEXPR (a
->expr
);
5368 WALK_SUBEXPR (co
->expr1
);
5370 for (b
= co
->block
; b
; b
= b
->block
)
5373 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5375 WALK_SUBEXPR (cp
->low
);
5376 WALK_SUBEXPR (cp
->high
);
5378 WALK_SUBCODE (b
->next
);
5383 case EXEC_DEALLOCATE
:
5386 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5387 WALK_SUBEXPR (a
->expr
);
5392 case EXEC_DO_CONCURRENT
:
5394 gfc_forall_iterator
*fa
;
5395 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5397 WALK_SUBEXPR (fa
->var
);
5398 WALK_SUBEXPR (fa
->start
);
5399 WALK_SUBEXPR (fa
->end
);
5400 WALK_SUBEXPR (fa
->stride
);
5402 if (co
->op
== EXEC_FORALL
)
5408 WALK_SUBEXPR (co
->ext
.open
->unit
);
5409 WALK_SUBEXPR (co
->ext
.open
->file
);
5410 WALK_SUBEXPR (co
->ext
.open
->status
);
5411 WALK_SUBEXPR (co
->ext
.open
->access
);
5412 WALK_SUBEXPR (co
->ext
.open
->form
);
5413 WALK_SUBEXPR (co
->ext
.open
->recl
);
5414 WALK_SUBEXPR (co
->ext
.open
->blank
);
5415 WALK_SUBEXPR (co
->ext
.open
->position
);
5416 WALK_SUBEXPR (co
->ext
.open
->action
);
5417 WALK_SUBEXPR (co
->ext
.open
->delim
);
5418 WALK_SUBEXPR (co
->ext
.open
->pad
);
5419 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5420 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5421 WALK_SUBEXPR (co
->ext
.open
->convert
);
5422 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5423 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5424 WALK_SUBEXPR (co
->ext
.open
->round
);
5425 WALK_SUBEXPR (co
->ext
.open
->sign
);
5426 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5427 WALK_SUBEXPR (co
->ext
.open
->id
);
5428 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5429 WALK_SUBEXPR (co
->ext
.open
->share
);
5430 WALK_SUBEXPR (co
->ext
.open
->cc
);
5434 WALK_SUBEXPR (co
->ext
.close
->unit
);
5435 WALK_SUBEXPR (co
->ext
.close
->status
);
5436 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5437 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5440 case EXEC_BACKSPACE
:
5444 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5445 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5446 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5450 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5451 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5452 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5453 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5454 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5455 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5456 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5457 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5458 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5459 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5460 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5461 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5462 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5463 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5464 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5465 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5466 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5467 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5468 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5469 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5470 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5471 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5472 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5473 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5474 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5475 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5476 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5477 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5478 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5479 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5480 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5481 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5482 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5483 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5484 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5485 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5489 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5490 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5491 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5492 WALK_SUBEXPR (co
->ext
.wait
->id
);
5497 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5498 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5499 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5500 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5501 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5502 WALK_SUBEXPR (co
->ext
.dt
->size
);
5503 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5504 WALK_SUBEXPR (co
->ext
.dt
->id
);
5505 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5506 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5507 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5508 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5509 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5510 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5511 WALK_SUBEXPR (co
->ext
.dt
->round
);
5512 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5513 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5516 case EXEC_OACC_ATOMIC
:
5517 case EXEC_OMP_ATOMIC
:
5518 in_omp_atomic
= true;
5521 case EXEC_OMP_PARALLEL
:
5522 case EXEC_OMP_PARALLEL_DO
:
5523 case EXEC_OMP_PARALLEL_DO_SIMD
:
5524 case EXEC_OMP_PARALLEL_SECTIONS
:
5526 in_omp_workshare
= false;
5528 /* This goto serves as a shortcut to avoid code
5529 duplication or a larger if or switch statement. */
5530 goto check_omp_clauses
;
5532 case EXEC_OMP_WORKSHARE
:
5533 case EXEC_OMP_PARALLEL_WORKSHARE
:
5535 in_omp_workshare
= true;
5539 case EXEC_OMP_CRITICAL
:
5540 case EXEC_OMP_DISTRIBUTE
:
5541 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5542 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5543 case EXEC_OMP_DISTRIBUTE_SIMD
:
5545 case EXEC_OMP_DO_SIMD
:
5546 case EXEC_OMP_ORDERED
:
5547 case EXEC_OMP_SECTIONS
:
5548 case EXEC_OMP_SINGLE
:
5549 case EXEC_OMP_END_SINGLE
:
5551 case EXEC_OMP_TASKLOOP
:
5552 case EXEC_OMP_TASKLOOP_SIMD
:
5553 case EXEC_OMP_TARGET
:
5554 case EXEC_OMP_TARGET_DATA
:
5555 case EXEC_OMP_TARGET_ENTER_DATA
:
5556 case EXEC_OMP_TARGET_EXIT_DATA
:
5557 case EXEC_OMP_TARGET_PARALLEL
:
5558 case EXEC_OMP_TARGET_PARALLEL_DO
:
5559 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5560 case EXEC_OMP_TARGET_SIMD
:
5561 case EXEC_OMP_TARGET_TEAMS
:
5562 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5563 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5564 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5565 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5566 case EXEC_OMP_TARGET_UPDATE
:
5568 case EXEC_OMP_TEAMS
:
5569 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5570 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5571 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5572 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5574 /* Come to this label only from the
5575 EXEC_OMP_PARALLEL_* cases above. */
5579 if (co
->ext
.omp_clauses
)
5581 gfc_omp_namelist
*n
;
5582 static int list_types
[]
5583 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5584 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5586 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5587 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5588 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5589 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5590 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5591 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5592 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5593 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5594 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5595 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5596 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5597 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5598 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5599 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5600 WALK_SUBEXPR (co
->ext
.omp_clauses
->detach
);
5601 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5602 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5604 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5606 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5608 WALK_SUBEXPR (n
->expr
);
5615 WALK_SUBEXPR (co
->expr1
);
5616 WALK_SUBEXPR (co
->expr2
);
5617 WALK_SUBEXPR (co
->expr3
);
5618 WALK_SUBEXPR (co
->expr4
);
5619 for (b
= co
->block
; b
; b
= b
->block
)
5621 WALK_SUBEXPR (b
->expr1
);
5622 WALK_SUBEXPR (b
->expr2
);
5623 WALK_SUBCODE (b
->next
);
5626 if (co
->op
== EXEC_FORALL
)
5629 if (co
->op
== EXEC_DO
)
5632 if (co
->op
== EXEC_IF
)
5635 if (co
->op
== EXEC_SELECT
)
5638 in_omp_workshare
= saved_in_omp_workshare
;
5639 in_omp_atomic
= saved_in_omp_atomic
;
5640 in_where
= saved_in_where
;
5646 /* As a post-resolution step, check that all global symbols which are
5647 not declared in the source file match in their call signatures.
5648 We do this by looping over the code (and expressions). The first call
5649 we happen to find is assumed to be canonical. */
5652 /* Common tests for argument checking for both functions and subroutines. */
5655 check_externals_procedure (gfc_symbol
*sym
, locus
*loc
,
5656 gfc_actual_arglist
*actual
)
5659 gfc_symbol
*def_sym
= NULL
;
5661 if (sym
== NULL
|| sym
->attr
.is_bind_c
)
5664 if (sym
->attr
.proc
!= PROC_EXTERNAL
&& sym
->attr
.proc
!= PROC_UNKNOWN
)
5667 if (sym
->attr
.if_source
== IFSRC_IFBODY
|| sym
->attr
.if_source
== IFSRC_DECL
)
5670 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
5675 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &def_sym
);
5679 gfc_compare_actual_formal (&actual
, def_sym
->formal
, 0, 0, 0, loc
);
5683 /* First time we have seen this procedure called. Let's create an
5684 "interface" from the call and put it into a new namespace. */
5685 gfc_namespace
*save_ns
;
5686 gfc_symbol
*new_sym
;
5689 save_ns
= gfc_current_ns
;
5690 gsym
->ns
= gfc_get_namespace (gfc_current_ns
, 0);
5691 gsym
->ns
->proc_name
= sym
;
5693 gfc_get_symbol (sym
->name
, gsym
->ns
, &new_sym
);
5694 gcc_assert (new_sym
);
5695 new_sym
->attr
= sym
->attr
;
5696 new_sym
->attr
.if_source
= IFSRC_DECL
;
5697 gfc_current_ns
= gsym
->ns
;
5699 gfc_get_formal_from_actual_arglist (new_sym
, actual
);
5700 new_sym
->declared_at
= *loc
;
5701 gfc_current_ns
= save_ns
;
5707 /* Callback for calls of external routines. */
5710 check_externals_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5711 void *data ATTRIBUTE_UNUSED
)
5716 gfc_actual_arglist
*actual
;
5718 if (co
->op
!= EXEC_CALL
)
5721 sym
= co
->resolved_sym
;
5723 actual
= co
->ext
.actual
;
5725 return check_externals_procedure (sym
, loc
, actual
);
5729 /* Callback for external functions. */
5732 check_externals_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5733 void *data ATTRIBUTE_UNUSED
)
5738 gfc_actual_arglist
*actual
;
5740 if (e
->expr_type
!= EXPR_FUNCTION
)
5743 sym
= e
->value
.function
.esym
;
5748 actual
= e
->value
.function
.actual
;
5750 return check_externals_procedure (sym
, loc
, actual
);
5753 /* Function to check if any interface clashes with a global
5754 identifier, to be invoked via gfc_traverse_ns. */
5757 check_against_globals (gfc_symbol
*sym
)
5760 gfc_symbol
*def_sym
= NULL
;
5761 const char *sym_name
;
5764 if (sym
->attr
.if_source
!= IFSRC_IFBODY
|| sym
->attr
.flavor
!= FL_PROCEDURE
5765 || sym
->attr
.generic
|| sym
->error
)
5768 if (sym
->binding_label
)
5769 sym_name
= sym
->binding_label
;
5771 sym_name
= sym
->name
;
5773 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym_name
);
5774 if (gsym
&& gsym
->ns
)
5775 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &def_sym
);
5777 if (!def_sym
|| def_sym
->error
|| def_sym
->attr
.generic
)
5781 gfc_compare_interfaces (sym
, def_sym
, sym
->name
, 0, 1, buf
, sizeof(buf
),
5785 gfc_warning (0, "%s between %L and %L", buf
, &def_sym
->declared_at
,
5793 /* Do the code-walkling part for gfc_check_externals. */
5796 gfc_check_externals0 (gfc_namespace
*ns
)
5798 gfc_code_walker (&ns
->code
, check_externals_code
, check_externals_expr
, NULL
);
5800 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
5802 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
5803 gfc_check_externals0 (ns
);
5808 /* Called routine. */
5811 gfc_check_externals (gfc_namespace
*ns
)
5815 /* Turn errors into warnings if the user indicated this. */
5817 if (!pedantic
&& flag_allow_argument_mismatch
)
5818 gfc_errors_to_warnings (true);
5820 gfc_check_externals0 (ns
);
5821 gfc_traverse_ns (ns
, check_against_globals
);
5823 gfc_errors_to_warnings (false);
5826 /* Callback function. If there is a call to a subroutine which is
5827 neither pure nor implicit_pure, unset the implicit_pure flag for
5828 the caller and return -1. */
5831 implicit_pure_call (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5835 gfc_symbol
*caller_sym
;
5836 symbol_attribute
*a
;
5838 if (co
->op
!= EXEC_CALL
|| co
->resolved_sym
== NULL
)
5841 a
= &co
->resolved_sym
->attr
;
5842 if (a
->intrinsic
|| a
->pure
|| a
->implicit_pure
)
5845 caller_sym
= (gfc_symbol
*) sym_data
;
5846 gfc_unset_implicit_pure (caller_sym
);
5850 /* Callback function. If there is a call to a function which is
5851 neither pure nor implicit_pure, unset the implicit_pure flag for
5852 the caller and return 1. */
5855 implicit_pure_expr (gfc_expr
**e
, int *walk ATTRIBUTE_UNUSED
, void *sym_data
)
5857 gfc_expr
*expr
= *e
;
5858 gfc_symbol
*caller_sym
;
5860 symbol_attribute
*a
;
5862 if (expr
->expr_type
!= EXPR_FUNCTION
|| expr
->value
.function
.isym
)
5865 sym
= expr
->symtree
->n
.sym
;
5867 if (a
->pure
|| a
->implicit_pure
)
5870 caller_sym
= (gfc_symbol
*) sym_data
;
5871 gfc_unset_implicit_pure (caller_sym
);
5875 /* Go through all procedures in the namespace and unset the
5876 implicit_pure attribute for any procedure that calls something not
5877 pure or implicit pure. */
5880 gfc_fix_implicit_pure (gfc_namespace
*ns
)
5882 bool changed
= false;
5883 gfc_symbol
*proc
= ns
->proc_name
;
5885 if (proc
&& proc
->attr
.flavor
== FL_PROCEDURE
&& proc
->attr
.implicit_pure
5887 && gfc_code_walker (&ns
->code
, implicit_pure_call
, implicit_pure_expr
,
5888 (void *) ns
->proc_name
))
5891 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
5893 if (gfc_fix_implicit_pure (ns
))