1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2019 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 a WHERE statement. */
99 /* Keep track of iterators for array constructors. */
101 static int iterator_level
;
103 /* Keep track of DO loop levels. */
111 static vec
<do_t
> doloop_list
;
112 static int doloop_level
;
114 /* Keep track of if and select case levels. */
117 static int select_level
;
119 /* Vector of gfc_expr * to keep track of DO loops. */
121 struct my_struct
*evec
;
123 /* Keep track of association lists. */
125 static bool in_assoc_list
;
127 /* Counter for temporary variables. */
129 static int var_num
= 1;
131 /* What sort of matrix we are dealing with when inlining MATMUL. */
133 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
135 /* Keep track of the number of expressions we have inserted so far
140 /* Entry point - run all passes for a namespace. */
143 gfc_run_passes (gfc_namespace
*ns
)
146 /* Warn about dubious DO loops where the index might
153 doloop_list
.release ();
160 gfc_get_errors (&w
, &e
);
164 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
165 optimize_namespace (ns
);
167 if (flag_frontend_optimize
)
169 optimize_reduction (ns
);
170 if (flag_dump_fortran_optimized
)
171 gfc_dump_parse_tree (ns
, stdout
);
173 expr_array
.release ();
176 if (flag_realloc_lhs
)
177 realloc_strings (ns
);
182 /* Callback function: Warn if there is no location information in a
186 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
187 void *data ATTRIBUTE_UNUSED
)
190 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
191 gfc_warning_internal (0, "Inconsistent internal state: "
192 "No location in statement");
198 /* Callback function: Warn if there is no location information in an
202 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
203 void *data ATTRIBUTE_UNUSED
)
206 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
207 gfc_warning_internal (0, "Inconsistent internal state: "
208 "No location in expression near %L",
209 &((*current_code
)->loc
));
213 /* Run check for missing location information. */
216 check_locus (gfc_namespace
*ns
)
218 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
220 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
222 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
229 /* Callback for each gfc_code node invoked from check_realloc_strings.
230 For an allocatable LHS string which also appears as a variable on
242 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
243 void *data ATTRIBUTE_UNUSED
)
245 gfc_expr
*expr1
, *expr2
;
251 if (co
->op
!= EXEC_ASSIGN
)
255 if (expr1
->ts
.type
!= BT_CHARACTER
256 || !gfc_expr_attr(expr1
).allocatable
257 || !expr1
->ts
.deferred
)
260 if (is_fe_temp (expr1
))
263 expr2
= gfc_discard_nops (co
->expr2
);
265 if (expr2
->expr_type
== EXPR_VARIABLE
)
267 found_substr
= false;
268 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
270 if (ref
->type
== REF_SUBSTRING
)
279 else if (expr2
->expr_type
!= EXPR_ARRAY
280 && (expr2
->expr_type
!= EXPR_OP
281 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
284 if (!gfc_check_dependency (expr1
, expr2
, true))
287 /* gfc_check_dependency doesn't always pick up identical expressions.
288 However, eliminating the above sends the compiler into an infinite
289 loop on valid expressions. Without this check, the gimplifier emits
290 an ICE for a = a, where a is deferred character length. */
291 if (!gfc_dep_compare_expr (expr1
, expr2
))
295 inserted_block
= NULL
;
296 changed_statement
= NULL
;
297 n
= create_var (expr2
, "realloc_string");
302 /* Callback for each gfc_code node invoked through gfc_code_walker
303 from optimize_namespace. */
306 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
307 void *data ATTRIBUTE_UNUSED
)
314 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
315 || op
== EXEC_CALL_PPC
)
321 inserted_block
= NULL
;
322 changed_statement
= NULL
;
324 if (op
== EXEC_ASSIGN
)
325 optimize_assignment (*c
);
329 /* Callback for each gfc_expr node invoked through gfc_code_walker
330 from optimize_namespace. */
333 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
334 void *data ATTRIBUTE_UNUSED
)
338 if ((*e
)->expr_type
== EXPR_FUNCTION
)
341 function_expr
= true;
344 function_expr
= false;
346 if (optimize_trim (*e
))
347 gfc_simplify_expr (*e
, 0);
349 if (optimize_lexical_comparison (*e
))
350 gfc_simplify_expr (*e
, 0);
352 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
353 gfc_simplify_expr (*e
, 0);
355 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
356 switch ((*e
)->value
.function
.isym
->id
)
358 case GFC_ISYM_MINLOC
:
359 case GFC_ISYM_MAXLOC
:
360 optimize_minmaxloc (e
);
372 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
373 function is a scalar, just copy it; otherwise returns the new element, the
374 old one can be freed. */
377 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
379 gfc_expr
*fcn
, *e
= c
->expr
;
381 fcn
= gfc_copy_expr (e
);
384 gfc_constructor_base newbase
;
386 gfc_constructor
*new_c
;
389 new_expr
= gfc_get_expr ();
390 new_expr
->expr_type
= EXPR_ARRAY
;
391 new_expr
->ts
= e
->ts
;
392 new_expr
->where
= e
->where
;
394 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
395 new_c
->iterator
= c
->iterator
;
396 new_expr
->value
.constructor
= newbase
;
404 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
406 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
407 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
408 fn
->value
.function
.isym
->name
,
409 fn
->where
, 3, fcn
, NULL
, NULL
);
410 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
411 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
412 fn
->value
.function
.isym
->name
,
413 fn
->where
, 2, fcn
, NULL
);
415 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
417 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
423 /* Callback function for optimzation of reductions to scalars. Transform ANY
424 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
425 correspondingly. Handly only the simple cases without MASK and DIM. */
428 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
429 void *data ATTRIBUTE_UNUSED
)
434 gfc_actual_arglist
*a
;
435 gfc_actual_arglist
*dim
;
437 gfc_expr
*res
, *new_expr
;
438 gfc_actual_arglist
*mask
;
442 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
443 || fn
->value
.function
.isym
== NULL
)
446 id
= fn
->value
.function
.isym
->id
;
448 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
449 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
452 a
= fn
->value
.function
.actual
;
454 /* Don't handle MASK or DIM. */
458 if (dim
->expr
!= NULL
)
461 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
464 if ( mask
->expr
!= NULL
)
470 if (arg
->expr_type
!= EXPR_ARRAY
)
479 case GFC_ISYM_PRODUCT
:
480 op
= INTRINSIC_TIMES
;
495 c
= gfc_constructor_first (arg
->value
.constructor
);
497 /* Don't do any simplififcation if we have
498 - no element in the constructor or
499 - only have a single element in the array which contains an
505 res
= copy_walk_reduction_arg (c
, fn
);
507 c
= gfc_constructor_next (c
);
510 new_expr
= gfc_get_expr ();
511 new_expr
->ts
= fn
->ts
;
512 new_expr
->expr_type
= EXPR_OP
;
513 new_expr
->rank
= fn
->rank
;
514 new_expr
->where
= fn
->where
;
515 new_expr
->value
.op
.op
= op
;
516 new_expr
->value
.op
.op1
= res
;
517 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
519 c
= gfc_constructor_next (c
);
522 gfc_simplify_expr (res
, 0);
529 /* Callback function for common function elimination, called from cfe_expr_0.
530 Put all eligible function expressions into expr_array. */
533 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
534 void *data ATTRIBUTE_UNUSED
)
537 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
540 /* We don't do character functions with unknown charlens. */
541 if ((*e
)->ts
.type
== BT_CHARACTER
542 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
543 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
546 /* We don't do function elimination within FORALL statements, it can
547 lead to wrong-code in certain circumstances. */
549 if (forall_level
> 0)
552 /* Function elimination inside an iterator could lead to functions which
553 depend on iterator variables being moved outside. FIXME: We should check
554 if the functions do indeed depend on the iterator variable. */
556 if (iterator_level
> 0)
559 /* If we don't know the shape at compile time, we create an allocatable
560 temporary variable to hold the intermediate result, but only if
561 allocation on assignment is active. */
563 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
566 /* Skip the test for pure functions if -faggressive-function-elimination
568 if ((*e
)->value
.function
.esym
)
570 /* Don't create an array temporary for elemental functions. */
571 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
574 /* Only eliminate potentially impure functions if the
575 user specifically requested it. */
576 if (!flag_aggressive_function_elimination
577 && !(*e
)->value
.function
.esym
->attr
.pure
578 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
582 if ((*e
)->value
.function
.isym
)
584 /* Conversions are handled on the fly by the middle end,
585 transpose during trans-* stages and TRANSFER by the middle end. */
586 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
587 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
588 || gfc_inline_intrinsic_function_p (*e
))
591 /* Don't create an array temporary for elemental functions,
592 as this would be wasteful of memory.
593 FIXME: Create a scalar temporary during scalarization. */
594 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
597 if (!(*e
)->value
.function
.isym
->pure
)
601 expr_array
.safe_push (e
);
605 /* Auxiliary function to check if an expression is a temporary created by
609 is_fe_temp (gfc_expr
*e
)
611 if (e
->expr_type
!= EXPR_VARIABLE
)
614 return e
->symtree
->n
.sym
->attr
.fe_temp
;
617 /* Determine the length of a string, if it can be evaluated as a constant
618 expression. Return a newly allocated gfc_expr or NULL on failure.
619 If the user specified a substring which is potentially longer than
620 the string itself, the string will be padded with spaces, which
624 constant_string_length (gfc_expr
*e
)
634 length
= e
->ts
.u
.cl
->length
;
635 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
636 return gfc_copy_expr(length
);
639 /* See if there is a substring. If it has a constant length, return
640 that and NULL otherwise. */
641 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
643 if (ref
->type
== REF_SUBSTRING
)
645 if (gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
647 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
650 mpz_add_ui (res
->value
.integer
, value
, 1);
659 /* Return length of char symbol, if constant. */
660 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
661 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
662 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
663 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
669 /* Insert a block at the current position unless it has already
670 been inserted; in this case use the one already there. */
672 static gfc_namespace
*
677 /* If the block hasn't already been created, do so. */
678 if (inserted_block
== NULL
)
680 inserted_block
= XCNEW (gfc_code
);
681 inserted_block
->op
= EXEC_BLOCK
;
682 inserted_block
->loc
= (*current_code
)->loc
;
683 ns
= gfc_build_block_ns (current_ns
);
684 inserted_block
->ext
.block
.ns
= ns
;
685 inserted_block
->ext
.block
.assoc
= NULL
;
687 ns
->code
= *current_code
;
689 /* If the statement has a label, make sure it is transferred to
690 the newly created block. */
692 if ((*current_code
)->here
)
694 inserted_block
->here
= (*current_code
)->here
;
695 (*current_code
)->here
= NULL
;
698 inserted_block
->next
= (*current_code
)->next
;
699 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
700 (*current_code
)->next
= NULL
;
701 /* Insert the BLOCK at the right position. */
702 *current_code
= inserted_block
;
703 ns
->parent
= current_ns
;
706 ns
= inserted_block
->ext
.block
.ns
;
712 /* Insert a call to the intrinsic len. Use a different name for
713 the symbol tree so we don't run into trouble when the user has
714 renamed len for some reason. */
717 get_len_call (gfc_expr
*str
)
720 gfc_actual_arglist
*actual_arglist
;
722 fcn
= gfc_get_expr ();
723 fcn
->expr_type
= EXPR_FUNCTION
;
724 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN
);
725 actual_arglist
= gfc_get_actual_arglist ();
726 actual_arglist
->expr
= str
;
728 fcn
->value
.function
.actual
= actual_arglist
;
729 fcn
->where
= str
->where
;
730 fcn
->ts
.type
= BT_INTEGER
;
731 fcn
->ts
.kind
= gfc_charlen_int_kind
;
733 gfc_get_sym_tree ("__internal_len", current_ns
, &fcn
->symtree
, false);
734 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
735 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
736 fcn
->symtree
->n
.sym
->attr
.function
= 1;
737 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
738 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
739 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
740 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
746 /* Returns a new expression (a variable) to be used in place of the old one,
747 with an optional assignment statement before the current statement to set
748 the value of the variable. Creates a new BLOCK for the statement if that
749 hasn't already been done and puts the statement, plus the newly created
750 variables, in that block. Special cases: If the expression is constant or
751 a temporary which has already been created, just copy it. */
754 create_var (gfc_expr
* e
, const char *vname
)
756 char name
[GFC_MAX_SYMBOL_LEN
+1];
757 gfc_symtree
*symtree
;
765 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
766 return gfc_copy_expr (e
);
768 /* Creation of an array of unknown size requires realloc on assignment.
769 If that is not possible, just return NULL. */
770 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
773 ns
= insert_block ();
776 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
778 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
780 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
783 symbol
= symtree
->n
.sym
;
788 symbol
->as
= gfc_get_array_spec ();
789 symbol
->as
->rank
= e
->rank
;
791 if (e
->shape
== NULL
)
793 /* We don't know the shape at compile time, so we use an
795 symbol
->as
->type
= AS_DEFERRED
;
796 symbol
->attr
.allocatable
= 1;
800 symbol
->as
->type
= AS_EXPLICIT
;
801 /* Copy the shape. */
802 for (i
=0; i
<e
->rank
; i
++)
806 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
808 mpz_set_si (p
->value
.integer
, 1);
809 symbol
->as
->lower
[i
] = p
;
811 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
813 mpz_set (q
->value
.integer
, e
->shape
[i
]);
814 symbol
->as
->upper
[i
] = q
;
820 if (e
->ts
.type
== BT_CHARACTER
)
824 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
825 length
= constant_string_length (e
);
827 symbol
->ts
.u
.cl
->length
= length
;
828 else if (e
->expr_type
== EXPR_VARIABLE
829 && e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
830 && e
->ts
.u
.cl
->length
)
831 symbol
->ts
.u
.cl
->length
= get_len_call (gfc_copy_expr (e
));
834 symbol
->attr
.allocatable
= 1;
835 symbol
->ts
.u
.cl
->length
= NULL
;
836 symbol
->ts
.deferred
= 1;
841 symbol
->attr
.flavor
= FL_VARIABLE
;
842 symbol
->attr
.referenced
= 1;
843 symbol
->attr
.dimension
= e
->rank
> 0;
844 symbol
->attr
.fe_temp
= 1;
845 gfc_commit_symbol (symbol
);
847 result
= gfc_get_expr ();
848 result
->expr_type
= EXPR_VARIABLE
;
849 result
->ts
= symbol
->ts
;
850 result
->ts
.deferred
= deferred
;
851 result
->rank
= e
->rank
;
852 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
853 result
->symtree
= symtree
;
854 result
->where
= e
->where
;
857 result
->ref
= gfc_get_ref ();
858 result
->ref
->type
= REF_ARRAY
;
859 result
->ref
->u
.ar
.type
= AR_FULL
;
860 result
->ref
->u
.ar
.where
= e
->where
;
861 result
->ref
->u
.ar
.dimen
= e
->rank
;
862 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
863 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
864 if (warn_array_temporaries
)
865 gfc_warning (OPT_Warray_temporaries
,
866 "Creating array temporary at %L", &(e
->where
));
869 /* Generate the new assignment. */
870 n
= XCNEW (gfc_code
);
872 n
->loc
= (*current_code
)->loc
;
873 n
->next
= *changed_statement
;
874 n
->expr1
= gfc_copy_expr (result
);
876 *changed_statement
= n
;
882 /* Warn about function elimination. */
885 do_warn_function_elimination (gfc_expr
*e
)
888 if (e
->expr_type
== EXPR_FUNCTION
889 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
892 gfc_warning (OPT_Wfunction_elimination
,
893 "Removing call to impure function %qs at %L", name
,
896 gfc_warning (OPT_Wfunction_elimination
,
897 "Removing call to impure function at %L",
903 /* Callback function for the code walker for doing common function
904 elimination. This builds up the list of functions in the expression
905 and goes through them to detect duplicates, which it then replaces
909 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
910 void *data ATTRIBUTE_UNUSED
)
916 /* Don't do this optimization within OMP workshare or ASSOC lists. */
918 if (in_omp_workshare
|| in_assoc_list
)
924 expr_array
.release ();
926 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
928 /* Walk through all the functions. */
930 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
932 /* Skip if the function has been replaced by a variable already. */
933 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
940 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
943 newvar
= create_var (*ei
, "fcn");
945 if (warn_function_elimination
)
946 do_warn_function_elimination (*ej
);
949 *ej
= gfc_copy_expr (newvar
);
956 /* We did all the necessary walking in this function. */
961 /* Callback function for common function elimination, called from
962 gfc_code_walker. This keeps track of the current code, in order
963 to insert statements as needed. */
966 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
969 inserted_block
= NULL
;
970 changed_statement
= NULL
;
972 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
973 and allocation on assigment are prohibited inside WHERE, and finally
974 masking an expression would lead to wrong-code when replacing
977 b = sum(foo(a) + foo(a))
988 if ((*c
)->op
== EXEC_WHERE
)
998 /* Dummy function for expression call back, for use when we
999 really don't want to do any walking. */
1002 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
1003 void *data ATTRIBUTE_UNUSED
)
1009 /* Dummy function for code callback, for use when we really
1010 don't want to do anything. */
1012 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
1013 int *walk_subtrees ATTRIBUTE_UNUSED
,
1014 void *data ATTRIBUTE_UNUSED
)
1019 /* Code callback function for converting
1026 This is because common function elimination would otherwise place the
1027 temporary variables outside the loop. */
1030 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1031 void *data ATTRIBUTE_UNUSED
)
1034 gfc_code
*c_if1
, *c_if2
, *c_exit
;
1035 gfc_code
*loopblock
;
1036 gfc_expr
*e_not
, *e_cond
;
1038 if (co
->op
!= EXEC_DO_WHILE
)
1041 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1046 /* Generate the condition of the if statement, which is .not. the original
1048 e_not
= gfc_get_expr ();
1049 e_not
->ts
= e_cond
->ts
;
1050 e_not
->where
= e_cond
->where
;
1051 e_not
->expr_type
= EXPR_OP
;
1052 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1053 e_not
->value
.op
.op1
= e_cond
;
1055 /* Generate the EXIT statement. */
1056 c_exit
= XCNEW (gfc_code
);
1057 c_exit
->op
= EXEC_EXIT
;
1058 c_exit
->ext
.which_construct
= co
;
1059 c_exit
->loc
= co
->loc
;
1061 /* Generate the IF statement. */
1062 c_if2
= XCNEW (gfc_code
);
1063 c_if2
->op
= EXEC_IF
;
1064 c_if2
->expr1
= e_not
;
1065 c_if2
->next
= c_exit
;
1066 c_if2
->loc
= co
->loc
;
1068 /* ... plus the one to chain it to. */
1069 c_if1
= XCNEW (gfc_code
);
1070 c_if1
->op
= EXEC_IF
;
1071 c_if1
->block
= c_if2
;
1072 c_if1
->loc
= co
->loc
;
1074 /* Make the DO WHILE loop into a DO block by replacing the condition
1075 with a true constant. */
1076 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1078 /* Hang the generated if statement into the loop body. */
1080 loopblock
= co
->block
->next
;
1081 co
->block
->next
= c_if1
;
1082 c_if1
->next
= loopblock
;
1087 /* Code callback function for converting
1100 because otherwise common function elimination would place the BLOCKs
1101 into the wrong place. */
1104 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1105 void *data ATTRIBUTE_UNUSED
)
1108 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1110 if (co
->op
!= EXEC_IF
)
1113 /* This loop starts out with the first ELSE statement. */
1114 else_stmt
= co
->block
->block
;
1116 while (else_stmt
!= NULL
)
1118 gfc_code
*next_else
;
1120 /* If there is no condition, we're done. */
1121 if (else_stmt
->expr1
== NULL
)
1124 next_else
= else_stmt
->block
;
1126 /* Generate the new IF statement. */
1127 c_if2
= XCNEW (gfc_code
);
1128 c_if2
->op
= EXEC_IF
;
1129 c_if2
->expr1
= else_stmt
->expr1
;
1130 c_if2
->next
= else_stmt
->next
;
1131 c_if2
->loc
= else_stmt
->loc
;
1132 c_if2
->block
= next_else
;
1134 /* ... plus the one to chain it to. */
1135 c_if1
= XCNEW (gfc_code
);
1136 c_if1
->op
= EXEC_IF
;
1137 c_if1
->block
= c_if2
;
1138 c_if1
->loc
= else_stmt
->loc
;
1140 /* Insert the new IF after the ELSE. */
1141 else_stmt
->expr1
= NULL
;
1142 else_stmt
->next
= c_if1
;
1143 else_stmt
->block
= NULL
;
1145 else_stmt
= next_else
;
1147 /* Don't walk subtrees. */
1151 /* Callback function to var_in_expr - return true if expr1 and
1152 expr2 are identical variables. */
1154 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1157 gfc_expr
*expr1
= (gfc_expr
*) data
;
1158 gfc_expr
*expr2
= *e
;
1160 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1163 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1166 /* Return true if expr1 is found in expr2. */
1169 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1171 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1173 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1178 struct do_stack
*prev
;
1183 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1184 optimize by replacing do loops with their analog array slices. For
1187 write (*,*) (a(i), i=1,4)
1191 write (*,*) a(1:4:1) . */
1194 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1197 gfc_expr
*new_e
, *expr
, *start
;
1199 struct do_stack ds_push
;
1200 int i
, future_rank
= 0;
1201 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1204 /* Find the first transfer/do statement. */
1205 for (curr
= code
; curr
; curr
= curr
->next
)
1207 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1211 /* Ensure it is the only transfer/do statement because cases like
1213 write (*,*) (a(i), b(i), i=1,4)
1215 cannot be optimized. */
1217 if (!curr
|| curr
->next
)
1220 if (curr
->op
== EXEC_DO
)
1222 if (curr
->ext
.iterator
->var
->ref
)
1224 ds_push
.prev
= stack_top
;
1225 ds_push
.iter
= curr
->ext
.iterator
;
1226 ds_push
.code
= curr
;
1227 stack_top
= &ds_push
;
1228 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1230 if (curr
!= stack_top
->code
&& !*has_reached
)
1232 curr
->block
->next
= NULL
;
1233 gfc_free_statements (curr
);
1236 *has_reached
= true;
1242 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1246 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1249 /* Find the iterators belonging to each variable and check conditions. */
1250 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1252 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1253 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1256 start
= ref
->u
.ar
.start
[i
];
1257 gfc_simplify_expr (start
, 0);
1258 switch (start
->expr_type
)
1262 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1266 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1267 if (!stack_top
|| !stack_top
->iter
1268 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1270 /* Check for (a(i,i), i=1,3). */
1274 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1281 iters
[i
] = stack_top
->iter
;
1282 stack_top
= stack_top
->prev
;
1290 switch (start
->value
.op
.op
)
1292 case INTRINSIC_PLUS
:
1293 case INTRINSIC_TIMES
:
1294 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1295 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1297 case INTRINSIC_MINUS
:
1298 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1299 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1300 || start
->value
.op
.op1
->ref
)
1302 if (!stack_top
|| !stack_top
->iter
1303 || stack_top
->iter
->var
->symtree
1304 != start
->value
.op
.op1
->symtree
)
1306 iters
[i
] = stack_top
->iter
;
1307 stack_top
= stack_top
->prev
;
1319 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1320 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1324 gfc_expr
*var
= iters
[i
]->var
;
1325 for (int j
= i
- 1; j
< i
; j
++)
1328 && (var_in_expr (var
, iters
[j
]->start
)
1329 || var_in_expr (var
, iters
[j
]->end
)
1330 || var_in_expr (var
, iters
[j
]->step
)))
1336 /* Create new expr. */
1337 new_e
= gfc_copy_expr (curr
->expr1
);
1338 new_e
->expr_type
= EXPR_VARIABLE
;
1339 new_e
->rank
= future_rank
;
1340 if (curr
->expr1
->shape
)
1341 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1343 /* Assign new starts, ends and strides if necessary. */
1344 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1348 start
= ref
->u
.ar
.start
[i
];
1349 switch (start
->expr_type
)
1352 gfc_internal_error ("bad expression");
1355 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1356 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1357 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1358 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1359 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1360 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1363 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1364 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1365 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1366 expr
= gfc_copy_expr (start
);
1367 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1368 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1369 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1370 expr
= gfc_copy_expr (start
);
1371 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1372 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1373 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1374 switch (start
->value
.op
.op
)
1376 case INTRINSIC_MINUS
:
1377 case INTRINSIC_PLUS
:
1378 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1380 case INTRINSIC_TIMES
:
1381 expr
= gfc_copy_expr (start
);
1382 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1383 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1384 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1387 gfc_internal_error ("bad op");
1391 gfc_internal_error ("bad expression");
1394 curr
->expr1
= new_e
;
1396 /* Insert modified statement. Check whether the statement needs to be
1397 inserted at the lowest level. */
1398 if (!stack_top
->iter
)
1402 curr
->next
= prev
->next
->next
;
1407 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1408 stack_top
->code
->block
->next
= curr
;
1412 stack_top
->code
->block
->next
= curr
;
1416 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1417 tries to optimize its block. */
1420 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1421 void *data ATTRIBUTE_UNUSED
)
1423 gfc_code
**curr
, *prev
= NULL
;
1424 struct do_stack write
, first
;
1428 || ((*code
)->block
->op
!= EXEC_WRITE
1429 && (*code
)->block
->op
!= EXEC_READ
))
1437 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1439 if ((*curr
)->op
== EXEC_DO
)
1441 first
.prev
= &write
;
1442 first
.iter
= (*curr
)->ext
.iterator
;
1445 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1453 /* Optimize a namespace, including all contained namespaces.
1454 flag_frontend_optimize and flag_fronend_loop_interchange are
1455 handled separately. */
1458 optimize_namespace (gfc_namespace
*ns
)
1460 gfc_namespace
*saved_ns
= gfc_current_ns
;
1462 gfc_current_ns
= ns
;
1465 in_assoc_list
= false;
1466 in_omp_workshare
= false;
1468 if (flag_frontend_optimize
)
1470 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1471 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1472 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1473 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1474 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1475 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1481 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1486 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1490 if (flag_external_blas
)
1491 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1494 if (flag_inline_matmul_limit
!= 0)
1495 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1499 if (flag_frontend_loop_interchange
)
1500 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1503 /* BLOCKs are handled in the expression walker below. */
1504 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1506 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1507 optimize_namespace (ns
);
1509 gfc_current_ns
= saved_ns
;
1512 /* Handle dependencies for allocatable strings which potentially redefine
1513 themselves in an assignment. */
1516 realloc_strings (gfc_namespace
*ns
)
1519 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1521 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1523 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1524 realloc_strings (ns
);
1530 optimize_reduction (gfc_namespace
*ns
)
1533 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1534 callback_reduction
, NULL
);
1536 /* BLOCKs are handled in the expression walker below. */
1537 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1539 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1540 optimize_reduction (ns
);
1544 /* Replace code like
1547 a = matmul(b,c) ; a = a + d
1548 where the array function is not elemental and not allocatable
1549 and does not depend on the left-hand side.
1553 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1561 if (e
->expr_type
== EXPR_OP
)
1563 switch (e
->value
.op
.op
)
1565 /* Unary operators and exponentiation: Only look at a single
1568 case INTRINSIC_UPLUS
:
1569 case INTRINSIC_UMINUS
:
1570 case INTRINSIC_PARENTHESES
:
1571 case INTRINSIC_POWER
:
1572 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1576 case INTRINSIC_CONCAT
:
1577 /* Do not do string concatenations. */
1581 /* Binary operators. */
1582 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1585 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1591 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1592 && ! (e
->value
.function
.esym
1593 && (e
->value
.function
.esym
->attr
.elemental
1594 || e
->value
.function
.esym
->attr
.allocatable
1595 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1596 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1597 && ! (e
->value
.function
.isym
1598 && (e
->value
.function
.isym
->elemental
1599 || e
->ts
.type
!= c
->expr1
->ts
.type
1600 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1601 && ! gfc_inline_intrinsic_function_p (e
))
1607 /* Insert a new assignment statement after the current one. */
1608 n
= XCNEW (gfc_code
);
1609 n
->op
= EXEC_ASSIGN
;
1614 n
->expr1
= gfc_copy_expr (c
->expr1
);
1615 n
->expr2
= c
->expr2
;
1616 new_expr
= gfc_copy_expr (c
->expr1
);
1624 /* Nothing to optimize. */
1628 /* Remove unneeded TRIMs at the end of expressions. */
1631 remove_trim (gfc_expr
*rhs
)
1639 /* Check for a // b // trim(c). Looping is probably not
1640 necessary because the parser usually generates
1641 (// (// a b ) trim(c) ) , but better safe than sorry. */
1643 while (rhs
->expr_type
== EXPR_OP
1644 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1645 rhs
= rhs
->value
.op
.op2
;
1647 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1648 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1650 strip_function_call (rhs
);
1651 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1659 /* Optimizations for an assignment. */
1662 optimize_assignment (gfc_code
* c
)
1664 gfc_expr
*lhs
, *rhs
;
1669 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1671 /* Optimize a = trim(b) to a = b. */
1674 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1675 if (is_empty_string (rhs
))
1676 rhs
->value
.character
.length
= 0;
1679 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1680 optimize_binop_array_assignment (c
, &rhs
, false);
1684 /* Remove an unneeded function call, modifying the expression.
1685 This replaces the function call with the value of its
1686 first argument. The rest of the argument list is freed. */
1689 strip_function_call (gfc_expr
*e
)
1692 gfc_actual_arglist
*a
;
1694 a
= e
->value
.function
.actual
;
1696 /* We should have at least one argument. */
1697 gcc_assert (a
->expr
!= NULL
);
1701 /* Free the remaining arglist, if any. */
1703 gfc_free_actual_arglist (a
->next
);
1705 /* Graft the argument expression onto the original function. */
1711 /* Optimization of lexical comparison functions. */
1714 optimize_lexical_comparison (gfc_expr
*e
)
1716 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1719 switch (e
->value
.function
.isym
->id
)
1722 return optimize_comparison (e
, INTRINSIC_LE
);
1725 return optimize_comparison (e
, INTRINSIC_GE
);
1728 return optimize_comparison (e
, INTRINSIC_GT
);
1731 return optimize_comparison (e
, INTRINSIC_LT
);
1739 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1740 do CHARACTER because of possible pessimization involving character
1744 combine_array_constructor (gfc_expr
*e
)
1747 gfc_expr
*op1
, *op2
;
1750 gfc_constructor
*c
, *new_c
;
1751 gfc_constructor_base oldbase
, newbase
;
1756 /* Array constructors have rank one. */
1760 /* Don't try to combine association lists, this makes no sense
1761 and leads to an ICE. */
1765 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1766 if (forall_level
> 0)
1769 /* Inside an iterator, things can get hairy; we are likely to create
1770 an invalid temporary variable. */
1771 if (iterator_level
> 0)
1774 /* WHERE also doesn't work. */
1778 op1
= e
->value
.op
.op1
;
1779 op2
= e
->value
.op
.op2
;
1784 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1785 scalar_first
= false;
1786 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1788 scalar_first
= true;
1789 op1
= e
->value
.op
.op2
;
1790 op2
= e
->value
.op
.op1
;
1795 if (op2
->ts
.type
== BT_CHARACTER
)
1798 /* This might be an expanded constructor with very many constant values. If
1799 we perform the operation here, we might end up with a long compile time
1800 and actually longer execution time, so a length bound is in order here.
1801 If the constructor constains something which is not a constant, it did
1802 not come from an expansion, so leave it alone. */
1804 #define CONSTR_LEN_MAX 4
1806 oldbase
= op1
->value
.constructor
;
1810 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1812 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1820 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1823 #undef CONSTR_LEN_MAX
1826 e
->expr_type
= EXPR_ARRAY
;
1828 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1830 for (c
= gfc_constructor_first (oldbase
); c
;
1831 c
= gfc_constructor_next (c
))
1833 new_expr
= gfc_get_expr ();
1834 new_expr
->ts
= e
->ts
;
1835 new_expr
->expr_type
= EXPR_OP
;
1836 new_expr
->rank
= c
->expr
->rank
;
1837 new_expr
->where
= c
->expr
->where
;
1838 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1842 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1843 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1847 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1848 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1851 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1852 new_c
->iterator
= c
->iterator
;
1856 gfc_free_expr (op1
);
1857 gfc_free_expr (op2
);
1858 gfc_free_expr (scalar
);
1860 e
->value
.constructor
= newbase
;
1864 /* Recursive optimization of operators. */
1867 optimize_op (gfc_expr
*e
)
1871 gfc_intrinsic_op op
= e
->value
.op
.op
;
1875 /* Only use new-style comparisons. */
1878 case INTRINSIC_EQ_OS
:
1882 case INTRINSIC_GE_OS
:
1886 case INTRINSIC_LE_OS
:
1890 case INTRINSIC_NE_OS
:
1894 case INTRINSIC_GT_OS
:
1898 case INTRINSIC_LT_OS
:
1914 changed
= optimize_comparison (e
, op
);
1917 /* Look at array constructors. */
1918 case INTRINSIC_PLUS
:
1919 case INTRINSIC_MINUS
:
1920 case INTRINSIC_TIMES
:
1921 case INTRINSIC_DIVIDE
:
1922 return combine_array_constructor (e
) || changed
;
1932 /* Return true if a constant string contains only blanks. */
1935 is_empty_string (gfc_expr
*e
)
1939 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1942 for (i
=0; i
< e
->value
.character
.length
; i
++)
1944 if (e
->value
.character
.string
[i
] != ' ')
1952 /* Insert a call to the intrinsic len_trim. Use a different name for
1953 the symbol tree so we don't run into trouble when the user has
1954 renamed len_trim for some reason. */
1957 get_len_trim_call (gfc_expr
*str
, int kind
)
1960 gfc_actual_arglist
*actual_arglist
, *next
;
1962 fcn
= gfc_get_expr ();
1963 fcn
->expr_type
= EXPR_FUNCTION
;
1964 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1965 actual_arglist
= gfc_get_actual_arglist ();
1966 actual_arglist
->expr
= str
;
1967 next
= gfc_get_actual_arglist ();
1968 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1969 actual_arglist
->next
= next
;
1971 fcn
->value
.function
.actual
= actual_arglist
;
1972 fcn
->where
= str
->where
;
1973 fcn
->ts
.type
= BT_INTEGER
;
1974 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1976 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1977 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1978 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1979 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1980 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1981 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1982 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1983 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1989 /* Optimize expressions for equality. */
1992 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1994 gfc_expr
*op1
, *op2
;
1998 gfc_actual_arglist
*firstarg
, *secondarg
;
2000 if (e
->expr_type
== EXPR_OP
)
2004 op1
= e
->value
.op
.op1
;
2005 op2
= e
->value
.op
.op2
;
2007 else if (e
->expr_type
== EXPR_FUNCTION
)
2009 /* One of the lexical comparison functions. */
2010 firstarg
= e
->value
.function
.actual
;
2011 secondarg
= firstarg
->next
;
2012 op1
= firstarg
->expr
;
2013 op2
= secondarg
->expr
;
2018 /* Strip off unneeded TRIM calls from string comparisons. */
2020 change
= remove_trim (op1
);
2022 if (remove_trim (op2
))
2025 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2026 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2027 handles them well). However, there are also cases that need a non-scalar
2028 argument. For example the any intrinsic. See PR 45380. */
2032 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2034 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2035 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2037 bool empty_op1
, empty_op2
;
2038 empty_op1
= is_empty_string (op1
);
2039 empty_op2
= is_empty_string (op2
);
2041 if (empty_op1
|| empty_op2
)
2047 /* This can only happen when an error for comparing
2048 characters of different kinds has already been issued. */
2049 if (empty_op1
&& empty_op2
)
2052 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2053 str
= empty_op1
? op2
: op1
;
2055 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2059 gfc_free_expr (op1
);
2061 gfc_free_expr (op2
);
2065 e
->value
.op
.op1
= fcn
;
2066 e
->value
.op
.op2
= zero
;
2071 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2073 if (flag_finite_math_only
2074 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2075 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2077 eq
= gfc_dep_compare_expr (op1
, op2
);
2080 /* Replace A // B < A // C with B < C, and A // B < C // B
2082 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2083 && op1
->expr_type
== EXPR_OP
2084 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2085 && op2
->expr_type
== EXPR_OP
2086 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2088 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2089 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2090 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2091 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2093 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2095 /* Watch out for 'A ' // x vs. 'A' // x. */
2097 if (op1_left
->expr_type
== EXPR_CONSTANT
2098 && op2_left
->expr_type
== EXPR_CONSTANT
2099 && op1_left
->value
.character
.length
2100 != op2_left
->value
.character
.length
)
2108 firstarg
->expr
= op1_right
;
2109 secondarg
->expr
= op2_right
;
2113 e
->value
.op
.op1
= op1_right
;
2114 e
->value
.op
.op2
= op2_right
;
2116 optimize_comparison (e
, op
);
2120 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2126 firstarg
->expr
= op1_left
;
2127 secondarg
->expr
= op2_left
;
2131 e
->value
.op
.op1
= op1_left
;
2132 e
->value
.op
.op2
= op2_left
;
2135 optimize_comparison (e
, op
);
2142 /* eq can only be -1, 0 or 1 at this point. */
2170 gfc_internal_error ("illegal OP in optimize_comparison");
2174 /* Replace the expression by a constant expression. The typespec
2175 and where remains the way it is. */
2178 e
->expr_type
= EXPR_CONSTANT
;
2179 e
->value
.logical
= result
;
2187 /* Optimize a trim function by replacing it with an equivalent substring
2188 involving a call to len_trim. This only works for expressions where
2189 variables are trimmed. Return true if anything was modified. */
2192 optimize_trim (gfc_expr
*e
)
2197 gfc_ref
**rr
= NULL
;
2199 /* Don't do this optimization within an argument list, because
2200 otherwise aliasing issues may occur. */
2202 if (count_arglist
!= 1)
2205 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2206 || e
->value
.function
.isym
== NULL
2207 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2210 a
= e
->value
.function
.actual
->expr
;
2212 if (a
->expr_type
!= EXPR_VARIABLE
)
2215 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2217 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2220 /* Follow all references to find the correct place to put the newly
2221 created reference. FIXME: Also handle substring references and
2222 array references. Array references cause strange regressions at
2227 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2229 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2234 strip_function_call (e
);
2239 /* Create the reference. */
2241 ref
= gfc_get_ref ();
2242 ref
->type
= REF_SUBSTRING
;
2244 /* Set the start of the reference. */
2246 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2248 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2250 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2252 /* Set the end of the reference to the call to len_trim. */
2254 ref
->u
.ss
.end
= fcn
;
2255 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2260 /* Optimize minloc(b), where b is rank 1 array, into
2261 (/ minloc(b, dim=1) /), and similarly for maxloc,
2262 as the latter forms are expanded inline. */
2265 optimize_minmaxloc (gfc_expr
**e
)
2268 gfc_actual_arglist
*a
;
2272 || fn
->value
.function
.actual
== NULL
2273 || fn
->value
.function
.actual
->expr
== NULL
2274 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2277 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2278 (*e
)->shape
= fn
->shape
;
2281 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2283 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2284 strcpy (name
, fn
->value
.function
.name
);
2285 p
= strstr (name
, "loc0");
2287 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2288 if (fn
->value
.function
.actual
->next
)
2290 a
= fn
->value
.function
.actual
->next
;
2291 gcc_assert (a
->expr
== NULL
);
2295 a
= gfc_get_actual_arglist ();
2296 fn
->value
.function
.actual
->next
= a
;
2298 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2300 mpz_set_ui (a
->expr
->value
.integer
, 1);
2303 /* Callback function for code checking that we do not pass a DO variable to an
2304 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2307 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2308 void *data ATTRIBUTE_UNUSED
)
2312 gfc_formal_arglist
*f
;
2313 gfc_actual_arglist
*a
;
2320 /* If the doloop_list grew, we have to truncate it here. */
2322 if ((unsigned) doloop_level
< doloop_list
.length())
2323 doloop_list
.truncate (doloop_level
);
2330 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2335 loop
.branch_level
= if_level
+ select_level
;
2336 loop
.seen_goto
= false;
2337 doloop_list
.safe_push (loop
);
2340 /* If anything could transfer control away from a suspicious
2341 subscript, make sure to set seen_goto in the current DO loop
2346 case EXEC_ERROR_STOP
:
2352 if (co
->ext
.open
->err
)
2357 if (co
->ext
.close
->err
)
2361 case EXEC_BACKSPACE
:
2366 if (co
->ext
.filepos
->err
)
2371 if (co
->ext
.filepos
->err
)
2377 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2382 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2383 loop
.seen_goto
= true;
2388 if (co
->resolved_sym
== NULL
)
2391 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2393 /* Withot a formal arglist, there is only unknown INTENT,
2394 which we don't check for. */
2402 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2410 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2412 if (a
->expr
&& a
->expr
->symtree
2413 && a
->expr
->symtree
->n
.sym
== do_sym
)
2415 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2416 gfc_error_now ("Variable %qs at %L set to undefined "
2417 "value inside loop beginning at %L as "
2418 "INTENT(OUT) argument to subroutine %qs",
2419 do_sym
->name
, &a
->expr
->where
,
2420 &(doloop_list
[i
].c
->loc
),
2421 co
->symtree
->n
.sym
->name
);
2422 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2423 gfc_error_now ("Variable %qs at %L not definable inside "
2424 "loop beginning at %L as INTENT(INOUT) "
2425 "argument to subroutine %qs",
2426 do_sym
->name
, &a
->expr
->where
,
2427 &(doloop_list
[i
].c
->loc
),
2428 co
->symtree
->n
.sym
->name
);
2439 if (seen_goto
&& doloop_level
> 0)
2440 doloop_list
[doloop_level
-1].seen_goto
= true;
2445 /* Callback function to warn about different things within DO loops. */
2448 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2449 void *data ATTRIBUTE_UNUSED
)
2453 if (doloop_list
.length () == 0)
2456 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2459 last
= &doloop_list
.last();
2460 if (last
->seen_goto
&& !warn_do_subscript
)
2463 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2475 /* Callback function - if the expression is the variable in data->sym,
2476 replace it with a constant from data->val. */
2479 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2486 if (ex
->expr_type
!= EXPR_VARIABLE
)
2489 d
= (insert_index_t
*) data
;
2490 if (ex
->symtree
->n
.sym
!= d
->sym
)
2493 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2494 mpz_set (n
->value
.integer
, d
->val
);
2501 /* In the expression e, replace occurrences of the variable sym with
2502 val. If this results in a constant expression, return true and
2503 return the value in ret. Return false if the expression already
2504 is a constant. Caller has to clear ret in that case. */
2507 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2510 insert_index_t data
;
2513 if (e
->expr_type
== EXPR_CONSTANT
)
2516 n
= gfc_copy_expr (e
);
2518 mpz_init_set (data
.val
, val
);
2519 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2521 /* Suppress errors here - we could get errors here such as an
2522 out of bounds access for arrays, see PR 90563. */
2523 gfc_push_suppress_errors ();
2524 gfc_simplify_expr (n
, 0);
2525 gfc_pop_suppress_errors ();
2527 if (n
->expr_type
== EXPR_CONSTANT
)
2530 mpz_init_set (ret
, n
->value
.integer
);
2535 mpz_clear (data
.val
);
2541 /* Check array subscripts for possible out-of-bounds accesses in DO
2542 loops with constant bounds. */
2545 do_subscript (gfc_expr
**e
)
2555 /* Constants are already checked. */
2556 if (v
->expr_type
== EXPR_CONSTANT
)
2559 /* Wrong warnings will be generated in an associate list. */
2563 /* We already warned about this. */
2569 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2571 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2574 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2577 mpz_t do_start
, do_step
, do_end
;
2578 bool have_do_start
, have_do_end
;
2579 bool error_not_proven
;
2586 /* If we are within a branch, or a goto or equivalent
2587 was seen in the DO loop before, then we cannot prove that
2588 this expression is actually evaluated. Don't do anything
2589 unless we want to see it all. */
2590 error_not_proven
= lp
->seen_goto
2591 || lp
->branch_level
< if_level
+ select_level
;
2593 if (error_not_proven
&& !warn_do_subscript
)
2596 if (error_not_proven
)
2597 warn
= OPT_Wdo_subscript
;
2601 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2602 if (do_sym
->ts
.type
!= BT_INTEGER
)
2605 /* If we do not know about the stepsize, the loop may be zero trip.
2606 Do not warn in this case. */
2608 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2609 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2613 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2615 have_do_start
= true;
2616 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2619 have_do_start
= false;
2621 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2624 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2627 have_do_end
= false;
2629 if (!have_do_start
&& !have_do_end
)
2632 /* No warning inside a zero-trip loop. */
2633 if (have_do_start
&& have_do_end
)
2637 sgn
= mpz_cmp_ui (do_step
, 0);
2638 cmp
= mpz_cmp (do_end
, do_start
);
2639 if ((sgn
> 0 && cmp
< 0) || (sgn
< 0 && cmp
> 0))
2643 /* May have to correct the end value if the step does not equal
2645 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2651 mpz_sub (diff
, do_end
, do_start
);
2652 mpz_tdiv_r (rem
, diff
, do_step
);
2653 mpz_sub (do_end
, do_end
, rem
);
2658 for (i
= 0; i
< ar
->dimen
; i
++)
2661 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2662 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2664 if (ar
->as
->lower
[i
]
2665 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2666 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2667 gfc_warning (warn
, "Array reference at %L out of bounds "
2668 "(%ld < %ld) in loop beginning at %L",
2669 &ar
->start
[i
]->where
, mpz_get_si (val
),
2670 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2671 &doloop_list
[j
].c
->loc
);
2673 if (ar
->as
->upper
[i
]
2674 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2675 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2676 gfc_warning (warn
, "Array reference at %L out of bounds "
2677 "(%ld > %ld) in loop beginning at %L",
2678 &ar
->start
[i
]->where
, mpz_get_si (val
),
2679 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2680 &doloop_list
[j
].c
->loc
);
2685 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2686 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2688 if (ar
->as
->lower
[i
]
2689 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2690 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2691 gfc_warning (warn
, "Array reference at %L out of bounds "
2692 "(%ld < %ld) in loop beginning at %L",
2693 &ar
->start
[i
]->where
, mpz_get_si (val
),
2694 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2695 &doloop_list
[j
].c
->loc
);
2697 if (ar
->as
->upper
[i
]
2698 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2699 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2700 gfc_warning (warn
, "Array reference at %L out of bounds "
2701 "(%ld > %ld) in loop beginning at %L",
2702 &ar
->start
[i
]->where
, mpz_get_si (val
),
2703 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2704 &doloop_list
[j
].c
->loc
);
2714 /* Function for functions checking that we do not pass a DO variable
2715 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2718 do_intent (gfc_expr
**e
)
2720 gfc_formal_arglist
*f
;
2721 gfc_actual_arglist
*a
;
2728 if (expr
->expr_type
!= EXPR_FUNCTION
)
2731 /* Intrinsic functions don't modify their arguments. */
2733 if (expr
->value
.function
.isym
)
2736 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2738 /* Without a formal arglist, there is only unknown INTENT,
2739 which we don't check for. */
2743 a
= expr
->value
.function
.actual
;
2747 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2754 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2756 if (a
->expr
&& a
->expr
->symtree
2757 && a
->expr
->symtree
->n
.sym
== do_sym
)
2759 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2760 gfc_error_now ("Variable %qs at %L set to undefined value "
2761 "inside loop beginning at %L as INTENT(OUT) "
2762 "argument to function %qs", do_sym
->name
,
2763 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2764 expr
->symtree
->n
.sym
->name
);
2765 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2766 gfc_error_now ("Variable %qs at %L not definable inside loop"
2767 " beginning at %L as INTENT(INOUT) argument to"
2768 " function %qs", do_sym
->name
,
2769 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2770 expr
->symtree
->n
.sym
->name
);
2781 doloop_warn (gfc_namespace
*ns
)
2783 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2785 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
2787 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
2792 /* This selction deals with inlining calls to MATMUL. */
2794 /* Replace calls to matmul outside of straight assignments with a temporary
2795 variable so that later inlining will work. */
2798 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2802 bool *found
= (bool *) data
;
2806 if (e
->expr_type
!= EXPR_FUNCTION
2807 || e
->value
.function
.isym
== NULL
2808 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2811 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2812 || in_where
|| in_assoc_list
)
2815 /* Check if this is already in the form c = matmul(a,b). */
2817 if ((*current_code
)->expr2
== e
)
2820 n
= create_var (e
, "matmul");
2822 /* If create_var is unable to create a variable (for example if
2823 -fno-realloc-lhs is in force with a variable that does not have bounds
2824 known at compile-time), just return. */
2834 /* Set current_code and associated variables so that matmul_to_var_expr can
2838 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2839 void *data ATTRIBUTE_UNUSED
)
2841 if (current_code
!= c
)
2844 inserted_block
= NULL
;
2845 changed_statement
= NULL
;
2852 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2853 for a and b if there is a dependency between the arguments and the
2854 result variable or if a or b are the result of calculations that cannot
2855 be handled by the inliner. */
2858 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2859 void *data ATTRIBUTE_UNUSED
)
2861 gfc_expr
*expr1
, *expr2
;
2863 gfc_actual_arglist
*a
, *b
;
2865 gfc_expr
*matrix_a
, *matrix_b
;
2866 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2870 if (co
->op
!= EXEC_ASSIGN
)
2873 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2877 /* This has some duplication with inline_matmul_assign. This
2878 is because the creation of temporary variables could still fail,
2879 and inline_matmul_assign still needs to be able to handle these
2884 if (expr2
->expr_type
!= EXPR_FUNCTION
2885 || expr2
->value
.function
.isym
== NULL
2886 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2890 a
= expr2
->value
.function
.actual
;
2891 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2892 if (matrix_a
!= NULL
)
2894 if (matrix_a
->expr_type
== EXPR_VARIABLE
2895 && (gfc_check_dependency (matrix_a
, expr1
, true)
2896 || gfc_has_dimen_vector_ref (matrix_a
)))
2904 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2905 if (matrix_b
!= NULL
)
2907 if (matrix_b
->expr_type
== EXPR_VARIABLE
2908 && (gfc_check_dependency (matrix_b
, expr1
, true)
2909 || gfc_has_dimen_vector_ref (matrix_b
)))
2915 if (!a_tmp
&& !b_tmp
)
2919 inserted_block
= NULL
;
2920 changed_statement
= NULL
;
2924 at
= create_var (a
->expr
,"mma");
2931 bt
= create_var (b
->expr
,"mmb");
2938 /* Auxiliary function to build and simplify an array inquiry function.
2939 dim is zero-based. */
2942 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
2945 gfc_expr
*dim_arg
, *kind
;
2951 case GFC_ISYM_LBOUND
:
2952 name
= "_gfortran_lbound";
2955 case GFC_ISYM_UBOUND
:
2956 name
= "_gfortran_ubound";
2960 name
= "_gfortran_size";
2967 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2969 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2972 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2973 gfc_index_integer_kind
);
2975 ec
= gfc_copy_expr (e
);
2977 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2979 ec
->no_bounds_check
= 1;
2980 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2982 gfc_simplify_expr (fcn
, 0);
2983 fcn
->no_bounds_check
= 1;
2987 /* Builds a logical expression. */
2990 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2995 ts
.type
= BT_LOGICAL
;
2996 ts
.kind
= gfc_default_logical_kind
;
2997 res
= gfc_get_expr ();
2998 res
->where
= e1
->where
;
2999 res
->expr_type
= EXPR_OP
;
3000 res
->value
.op
.op
= op
;
3001 res
->value
.op
.op1
= e1
;
3002 res
->value
.op
.op2
= e2
;
3009 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3010 compatible typespecs. */
3013 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3017 res
= gfc_get_expr ();
3019 res
->where
= e1
->where
;
3020 res
->expr_type
= EXPR_OP
;
3021 res
->value
.op
.op
= op
;
3022 res
->value
.op
.op1
= e1
;
3023 res
->value
.op
.op2
= e2
;
3024 gfc_simplify_expr (res
, 0);
3028 /* Generate the IF statement for a runtime check if we want to do inlining or
3029 not - putting in the code for both branches and putting it into the syntax
3030 tree is the caller's responsibility. For fixed array sizes, this should be
3031 removed by DCE. Only called for rank-two matrices A and B. */
3034 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3036 gfc_expr
*inline_limit
;
3037 gfc_code
*if_1
, *if_2
, *else_2
;
3038 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3042 /* Calculation is done in real to avoid integer overflow. */
3044 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3046 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3047 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3050 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3051 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3052 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3056 ts
.kind
= gfc_default_real_kind
;
3057 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3058 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3059 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3061 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3062 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3064 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3065 gfc_simplify_expr (cond
, 0);
3067 else_2
= XCNEW (gfc_code
);
3068 else_2
->op
= EXEC_IF
;
3069 else_2
->loc
= a
->where
;
3071 if_2
= XCNEW (gfc_code
);
3074 if_2
->loc
= a
->where
;
3075 if_2
->block
= else_2
;
3077 if_1
= XCNEW (gfc_code
);
3080 if_1
->loc
= a
->where
;
3086 /* Insert code to issue a runtime error if the expressions are not equal. */
3089 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3092 gfc_code
*if_1
, *if_2
;
3094 gfc_actual_arglist
*a1
, *a2
, *a3
;
3096 gcc_assert (e1
->where
.lb
);
3097 /* Build the call to runtime_error. */
3098 c
= XCNEW (gfc_code
);
3102 /* Get a null-terminated message string. */
3104 a1
= gfc_get_actual_arglist ();
3105 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3106 msg
, strlen(msg
)+1);
3109 /* Pass the value of the first expression. */
3110 a2
= gfc_get_actual_arglist ();
3111 a2
->expr
= gfc_copy_expr (e1
);
3114 /* Pass the value of the second expression. */
3115 a3
= gfc_get_actual_arglist ();
3116 a3
->expr
= gfc_copy_expr (e2
);
3119 gfc_check_fe_runtime_error (c
->ext
.actual
);
3120 gfc_resolve_fe_runtime_error (c
);
3122 if_2
= XCNEW (gfc_code
);
3124 if_2
->loc
= e1
->where
;
3127 if_1
= XCNEW (gfc_code
);
3130 if_1
->loc
= e1
->where
;
3132 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3133 gfc_simplify_expr (cond
, 0);
3139 /* Handle matrix reallocation. Caller is responsible to insert into
3142 For the two-dimensional case, build
3144 if (allocated(c)) then
3145 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3147 allocate (c(size(a,1), size(b,2)))
3150 allocate (c(size(a,1),size(b,2)))
3153 and for the other cases correspondingly.
3157 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3158 enum matrix_case m_case
)
3161 gfc_expr
*allocated
, *alloc_expr
;
3162 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3163 gfc_code
*else_alloc
;
3164 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3166 gfc_expr
*cond
, *ne1
, *ne2
;
3168 if (warn_realloc_lhs
)
3169 gfc_warning (OPT_Wrealloc_lhs
,
3170 "Code for reallocating the allocatable array at %L will "
3171 "be added", &c
->where
);
3173 alloc_expr
= gfc_copy_expr (c
);
3175 ar
= gfc_find_array_ref (alloc_expr
);
3176 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3178 /* c comes in as a full ref. Change it into a copy and make it into an
3179 element ref so it has the right form for for ALLOCATE. In the same
3180 switch statement, also generate the size comparison for the secod IF
3183 ar
->type
= AR_ELEMENT
;
3188 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3189 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3190 ne1
= build_logical_expr (INTRINSIC_NE
,
3191 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3192 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3193 ne2
= build_logical_expr (INTRINSIC_NE
,
3194 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3195 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3196 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3200 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3201 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3203 ne1
= build_logical_expr (INTRINSIC_NE
,
3204 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3205 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3206 ne2
= build_logical_expr (INTRINSIC_NE
,
3207 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3208 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3209 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3214 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3215 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3217 ne1
= build_logical_expr (INTRINSIC_NE
,
3218 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3219 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3220 ne2
= build_logical_expr (INTRINSIC_NE
,
3221 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3222 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3223 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3227 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3228 cond
= build_logical_expr (INTRINSIC_NE
,
3229 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3230 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3234 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3235 cond
= build_logical_expr (INTRINSIC_NE
,
3236 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3237 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3241 /* This can only happen for BLAS, we do not handle that case in
3243 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3244 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3246 ne1
= build_logical_expr (INTRINSIC_NE
,
3247 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3248 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3249 ne2
= build_logical_expr (INTRINSIC_NE
,
3250 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3251 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3253 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3261 gfc_simplify_expr (cond
, 0);
3263 /* We need two identical allocate statements in two
3264 branches of the IF statement. */
3266 allocate1
= XCNEW (gfc_code
);
3267 allocate1
->op
= EXEC_ALLOCATE
;
3268 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3269 allocate1
->loc
= c
->where
;
3270 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3272 allocate_else
= XCNEW (gfc_code
);
3273 allocate_else
->op
= EXEC_ALLOCATE
;
3274 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3275 allocate_else
->loc
= c
->where
;
3276 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3278 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3279 "_gfortran_allocated", c
->where
,
3280 1, gfc_copy_expr (c
));
3282 deallocate
= XCNEW (gfc_code
);
3283 deallocate
->op
= EXEC_DEALLOCATE
;
3284 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3285 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3286 deallocate
->next
= allocate1
;
3287 deallocate
->loc
= c
->where
;
3289 if_size_2
= XCNEW (gfc_code
);
3290 if_size_2
->op
= EXEC_IF
;
3291 if_size_2
->expr1
= cond
;
3292 if_size_2
->loc
= c
->where
;
3293 if_size_2
->next
= deallocate
;
3295 if_size_1
= XCNEW (gfc_code
);
3296 if_size_1
->op
= EXEC_IF
;
3297 if_size_1
->block
= if_size_2
;
3298 if_size_1
->loc
= c
->where
;
3300 else_alloc
= XCNEW (gfc_code
);
3301 else_alloc
->op
= EXEC_IF
;
3302 else_alloc
->loc
= c
->where
;
3303 else_alloc
->next
= allocate_else
;
3305 if_alloc_2
= XCNEW (gfc_code
);
3306 if_alloc_2
->op
= EXEC_IF
;
3307 if_alloc_2
->expr1
= allocated
;
3308 if_alloc_2
->loc
= c
->where
;
3309 if_alloc_2
->next
= if_size_1
;
3310 if_alloc_2
->block
= else_alloc
;
3312 if_alloc_1
= XCNEW (gfc_code
);
3313 if_alloc_1
->op
= EXEC_IF
;
3314 if_alloc_1
->block
= if_alloc_2
;
3315 if_alloc_1
->loc
= c
->where
;
3320 /* Callback function for has_function_or_op. */
3323 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3324 void *data ATTRIBUTE_UNUSED
)
3329 return (*e
)->expr_type
== EXPR_FUNCTION
3330 || (*e
)->expr_type
== EXPR_OP
;
3333 /* Returns true if the expression contains a function. */
3336 has_function_or_op (gfc_expr
**e
)
3341 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3344 /* Freeze (assign to a temporary variable) a single expression. */
3347 freeze_expr (gfc_expr
**ep
)
3350 if (has_function_or_op (ep
))
3352 ne
= create_var (*ep
, "freeze");
3357 /* Go through an expression's references and assign them to temporary
3358 variables if they contain functions. This is usually done prior to
3359 front-end scalarization to avoid multiple invocations of functions. */
3362 freeze_references (gfc_expr
*e
)
3368 for (r
=e
->ref
; r
; r
=r
->next
)
3370 if (r
->type
== REF_SUBSTRING
)
3372 if (r
->u
.ss
.start
!= NULL
)
3373 freeze_expr (&r
->u
.ss
.start
);
3375 if (r
->u
.ss
.end
!= NULL
)
3376 freeze_expr (&r
->u
.ss
.end
);
3378 else if (r
->type
== REF_ARRAY
)
3387 for (i
=0; i
<ar
->dimen
; i
++)
3389 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3391 freeze_expr (&ar
->start
[i
]);
3392 freeze_expr (&ar
->end
[i
]);
3393 freeze_expr (&ar
->stride
[i
]);
3395 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3397 freeze_expr (&ar
->start
[i
]);
3403 for (i
=0; i
<ar
->dimen
; i
++)
3404 freeze_expr (&ar
->start
[i
]);
3414 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3417 convert_to_index_kind (gfc_expr
*e
)
3421 gcc_assert (e
!= NULL
);
3423 res
= gfc_copy_expr (e
);
3425 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3427 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3431 ts
.type
= BT_INTEGER
;
3432 ts
.kind
= gfc_index_integer_kind
;
3434 gfc_convert_type_warn (e
, &ts
, 2, 0);
3440 /* Function to create a DO loop including creation of the
3441 iteration variable. gfc_expr are copied.*/
3444 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3445 gfc_namespace
*ns
, char *vname
)
3448 char name
[GFC_MAX_SYMBOL_LEN
+1];
3449 gfc_symtree
*symtree
;
3454 /* Create an expression for the iteration variable. */
3456 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3458 sprintf (name
, "__var_%d_do", var_num
++);
3461 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3464 /* Create the loop variable. */
3466 symbol
= symtree
->n
.sym
;
3467 symbol
->ts
.type
= BT_INTEGER
;
3468 symbol
->ts
.kind
= gfc_index_integer_kind
;
3469 symbol
->attr
.flavor
= FL_VARIABLE
;
3470 symbol
->attr
.referenced
= 1;
3471 symbol
->attr
.dimension
= 0;
3472 symbol
->attr
.fe_temp
= 1;
3473 gfc_commit_symbol (symbol
);
3475 i
= gfc_get_expr ();
3476 i
->expr_type
= EXPR_VARIABLE
;
3480 i
->symtree
= symtree
;
3482 /* ... and the nested DO statements. */
3483 n
= XCNEW (gfc_code
);
3486 n
->ext
.iterator
= gfc_get_iterator ();
3487 n
->ext
.iterator
->var
= i
;
3488 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3489 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3491 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3493 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3496 n2
= XCNEW (gfc_code
);
3504 /* Get the upper bound of the DO loops for matmul along a dimension. This
3508 get_size_m1 (gfc_expr
*e
, int dimen
)
3513 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3515 res
= gfc_get_constant_expr (BT_INTEGER
,
3516 gfc_index_integer_kind
, &e
->where
);
3517 mpz_sub_ui (res
->value
.integer
, size
, 1);
3522 res
= get_operand (INTRINSIC_MINUS
,
3523 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3524 gfc_get_int_expr (gfc_index_integer_kind
,
3526 gfc_simplify_expr (res
, 0);
3532 /* Function to return a scalarized expression. It is assumed that indices are
3533 zero based to make generation of DO loops easier. A zero as index will
3534 access the first element along a dimension. Single element references will
3535 be skipped. A NULL as an expression will be replaced by a full reference.
3536 This assumes that the index loops have gfc_index_integer_kind, and that all
3537 references have been frozen. */
3540 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3549 e
= gfc_copy_expr(e_in
);
3553 ar
= gfc_find_array_ref (e
);
3555 /* We scalarize count_index variables, reducing the rank by count_index. */
3557 e
->rank
= rank
- count_index
;
3559 was_fullref
= ar
->type
== AR_FULL
;
3562 ar
->type
= AR_ELEMENT
;
3564 ar
->type
= AR_SECTION
;
3566 /* Loop over the indices. For each index, create the expression
3567 index * stride + lbound(e, dim). */
3570 for (i
=0; i
< ar
->dimen
; i
++)
3572 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3574 if (index
[i_index
] != NULL
)
3576 gfc_expr
*lbound
, *nindex
;
3579 loopvar
= gfc_copy_expr (index
[i_index
]);
3585 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3586 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3590 ts
.type
= BT_INTEGER
;
3591 ts
.kind
= gfc_index_integer_kind
;
3592 gfc_convert_type (tmp
, &ts
, 2);
3594 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3599 /* Calculate the lower bound of the expression. */
3602 lbound
= gfc_copy_expr (ar
->start
[i
]);
3603 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3607 ts
.type
= BT_INTEGER
;
3608 ts
.kind
= gfc_index_integer_kind
;
3609 gfc_convert_type (lbound
, &ts
, 2);
3618 lbound_e
= gfc_copy_expr (e_in
);
3620 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3621 if (ref
->type
== REF_ARRAY
3622 && (ref
->u
.ar
.type
== AR_FULL
3623 || ref
->u
.ar
.type
== AR_SECTION
))
3628 gfc_free_ref_list (ref
->next
);
3634 /* Look at full individual sections, like a(:). The first index
3635 is the lbound of a full ref. */
3642 /* For assumed size, we need to keep around the final
3643 reference in order not to get an error on resolution
3644 below, and we cannot use AR_FULL. */
3646 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3648 ar
->type
= AR_SECTION
;
3657 for (j
= 0; j
< to
; j
++)
3659 gfc_free_expr (ar
->start
[j
]);
3660 ar
->start
[j
] = NULL
;
3661 gfc_free_expr (ar
->end
[j
]);
3663 gfc_free_expr (ar
->stride
[j
]);
3664 ar
->stride
[j
] = NULL
;
3667 /* We have to get rid of the shape, if there is one. Do
3668 so by freeing it and calling gfc_resolve to rebuild
3669 it, if necessary. */
3671 if (lbound_e
->shape
)
3672 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3674 lbound_e
->rank
= ar
->dimen
;
3675 gfc_resolve_expr (lbound_e
);
3677 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3679 gfc_free_expr (lbound_e
);
3682 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3684 gfc_free_expr (ar
->start
[i
]);
3685 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3687 gfc_free_expr (ar
->end
[i
]);
3689 gfc_free_expr (ar
->stride
[i
]);
3690 ar
->stride
[i
] = NULL
;
3691 gfc_simplify_expr (ar
->start
[i
], 0);
3693 else if (was_fullref
)
3695 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3701 /* Bounds checking will be done before the loops if -fcheck=bounds
3703 e
->no_bounds_check
= 1;
3707 /* Helper function to check for a dimen vector as subscript. */
3710 gfc_has_dimen_vector_ref (gfc_expr
*e
)
3715 ar
= gfc_find_array_ref (e
);
3717 if (ar
->type
== AR_FULL
)
3720 for (i
=0; i
<ar
->dimen
; i
++)
3721 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3727 /* If handed an expression of the form
3731 check if A can be handled by matmul and return if there is an uneven number
3732 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3733 otherwise. The caller has to check for the correct rank. */
3736 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3743 if (e
->expr_type
== EXPR_VARIABLE
)
3745 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3748 else if (e
->expr_type
== EXPR_FUNCTION
)
3750 if (e
->value
.function
.isym
== NULL
)
3753 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3755 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3756 *transpose
= !*transpose
;
3762 e
= e
->value
.function
.actual
->expr
;
3769 /* Macros for unified error messages. */
3771 #define B_ERROR_1 _("Incorrect extent in argument B in MATMUL intrinsic in " \
3772 "dimension 1: is %ld, should be %ld")
3774 #define C_ERROR_1 _("Array bound mismatch for dimension 1 of array " \
3777 #define C_ERROR_2 _("Array bound mismatch for dimension 2 of array " \
3781 /* Inline assignments of the form c = matmul(a,b).
3782 Handle only the cases currently where b and c are rank-two arrays.
3784 This basically translates the code to
3790 do k=0, size(a, 2)-1
3791 do i=0, size(a, 1)-1
3792 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3793 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3794 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3795 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3804 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3805 void *data ATTRIBUTE_UNUSED
)
3808 gfc_expr
*expr1
, *expr2
;
3809 gfc_expr
*matrix_a
, *matrix_b
;
3810 gfc_actual_arglist
*a
, *b
;
3811 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3813 gfc_expr
*u1
, *u2
, *u3
;
3815 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3817 gfc_expr
*var_1
, *var_2
, *var_3
;
3820 gfc_intrinsic_op op_times
, op_plus
;
3821 enum matrix_case m_case
;
3823 gfc_code
*if_limit
= NULL
;
3824 gfc_code
**next_code_point
;
3825 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3828 if (co
->op
!= EXEC_ASSIGN
)
3831 if (in_where
|| in_assoc_list
)
3834 /* The BLOCKS generated for the temporary variables and FORALL don't
3836 if (forall_level
> 0)
3839 /* For now don't do anything in OpenMP workshare, it confuses
3840 its translation, which expects only the allowed statements in there.
3841 We should figure out how to parallelize this eventually. */
3842 if (in_omp_workshare
)
3847 if (expr2
->expr_type
!= EXPR_FUNCTION
3848 || expr2
->value
.function
.isym
== NULL
3849 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3853 inserted_block
= NULL
;
3854 changed_statement
= NULL
;
3856 a
= expr2
->value
.function
.actual
;
3857 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3858 if (matrix_a
== NULL
)
3862 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3863 if (matrix_b
== NULL
)
3866 if (gfc_has_dimen_vector_ref (expr1
) || gfc_has_dimen_vector_ref (matrix_a
)
3867 || gfc_has_dimen_vector_ref (matrix_b
))
3870 /* We do not handle data dependencies yet. */
3871 if (gfc_check_dependency (expr1
, matrix_a
, true)
3872 || gfc_check_dependency (expr1
, matrix_b
, true))
3876 if (matrix_a
->rank
== 2)
3880 if (matrix_b
->rank
== 2 && !transpose_b
)
3885 if (matrix_b
->rank
== 1)
3887 else /* matrix_b->rank == 2 */
3896 else /* matrix_a->rank == 1 */
3898 if (matrix_b
->rank
== 2)
3908 ns
= insert_block ();
3910 /* Assign the type of the zero expression for initializing the resulting
3911 array, and the expression (+ and * for real, integer and complex;
3912 .and. and .or for logical. */
3914 switch(expr1
->ts
.type
)
3917 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3918 op_times
= INTRINSIC_TIMES
;
3919 op_plus
= INTRINSIC_PLUS
;
3923 op_times
= INTRINSIC_AND
;
3924 op_plus
= INTRINSIC_OR
;
3925 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3929 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3931 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3932 op_times
= INTRINSIC_TIMES
;
3933 op_plus
= INTRINSIC_PLUS
;
3937 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3939 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3940 op_times
= INTRINSIC_TIMES
;
3941 op_plus
= INTRINSIC_PLUS
;
3949 current_code
= &ns
->code
;
3951 /* Freeze the references, keeping track of how many temporary variables were
3954 freeze_references (matrix_a
);
3955 freeze_references (matrix_b
);
3956 freeze_references (expr1
);
3959 next_code_point
= current_code
;
3962 next_code_point
= &ns
->code
;
3963 for (i
=0; i
<n_vars
; i
++)
3964 next_code_point
= &(*next_code_point
)->next
;
3967 /* Take care of the inline flag. If the limit check evaluates to a
3968 constant, dead code elimination will eliminate the unneeded branch. */
3970 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
3971 && matrix_b
->rank
== 2)
3973 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
3974 flag_inline_matmul_limit
);
3976 /* Insert the original statement into the else branch. */
3977 if_limit
->block
->block
->next
= co
;
3980 /* ... and the new ones go into the original one. */
3981 *next_code_point
= if_limit
;
3982 next_code_point
= &if_limit
->block
->next
;
3985 zero_e
->no_bounds_check
= 1;
3987 assign_zero
= XCNEW (gfc_code
);
3988 assign_zero
->op
= EXEC_ASSIGN
;
3989 assign_zero
->loc
= co
->loc
;
3990 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3991 assign_zero
->expr1
->no_bounds_check
= 1;
3992 assign_zero
->expr2
= zero_e
;
3994 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
3996 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3999 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
4005 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4006 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4007 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4008 *next_code_point
= test
;
4009 next_code_point
= &test
->next
;
4013 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4014 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4015 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4016 *next_code_point
= test
;
4017 next_code_point
= &test
->next
;
4023 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4024 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4025 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4026 *next_code_point
= test
;
4027 next_code_point
= &test
->next
;
4031 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4032 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4033 test
= runtime_error_ne (c1
, b2
, C_ERROR_1
);
4034 *next_code_point
= test
;
4035 next_code_point
= &test
->next
;
4041 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4042 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4043 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4044 *next_code_point
= test
;
4045 next_code_point
= &test
->next
;
4049 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4050 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4051 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4052 *next_code_point
= test
;
4053 next_code_point
= &test
->next
;
4055 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4056 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4057 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4058 *next_code_point
= test
;
4059 next_code_point
= &test
->next
;
4065 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4066 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4067 /* matrix_b is transposed, hence dimension 1 for the error message. */
4068 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4069 *next_code_point
= test
;
4070 next_code_point
= &test
->next
;
4074 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4075 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4076 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4077 *next_code_point
= test
;
4078 next_code_point
= &test
->next
;
4080 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4081 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4082 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4083 *next_code_point
= test
;
4084 next_code_point
= &test
->next
;
4090 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4091 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4092 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4093 *next_code_point
= test
;
4094 next_code_point
= &test
->next
;
4098 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4099 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4100 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4101 *next_code_point
= test
;
4102 next_code_point
= &test
->next
;
4104 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4105 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4106 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4107 *next_code_point
= test
;
4108 next_code_point
= &test
->next
;
4117 /* Handle the reallocation, if needed. */
4121 gfc_code
*lhs_alloc
;
4123 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4125 *next_code_point
= lhs_alloc
;
4126 next_code_point
= &lhs_alloc
->next
;
4130 *next_code_point
= assign_zero
;
4132 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4134 assign_matmul
= XCNEW (gfc_code
);
4135 assign_matmul
->op
= EXEC_ASSIGN
;
4136 assign_matmul
->loc
= co
->loc
;
4138 /* Get the bounds for the loops, create them and create the scalarized
4145 u1
= get_size_m1 (matrix_b
, 2);
4146 u2
= get_size_m1 (matrix_a
, 2);
4147 u3
= get_size_m1 (matrix_a
, 1);
4149 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4150 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4151 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4153 do_1
->block
->next
= do_2
;
4154 do_2
->block
->next
= do_3
;
4155 do_3
->block
->next
= assign_matmul
;
4157 var_1
= do_1
->ext
.iterator
->var
;
4158 var_2
= do_2
->ext
.iterator
->var
;
4159 var_3
= do_3
->ext
.iterator
->var
;
4163 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4167 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4171 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4177 u1
= get_size_m1 (matrix_b
, 1);
4178 u2
= get_size_m1 (matrix_a
, 2);
4179 u3
= get_size_m1 (matrix_a
, 1);
4181 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4182 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4183 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4185 do_1
->block
->next
= do_2
;
4186 do_2
->block
->next
= do_3
;
4187 do_3
->block
->next
= assign_matmul
;
4189 var_1
= do_1
->ext
.iterator
->var
;
4190 var_2
= do_2
->ext
.iterator
->var
;
4191 var_3
= do_3
->ext
.iterator
->var
;
4195 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4199 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4203 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4209 u1
= get_size_m1 (matrix_a
, 2);
4210 u2
= get_size_m1 (matrix_b
, 2);
4211 u3
= get_size_m1 (matrix_a
, 1);
4213 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4214 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4215 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4217 do_1
->block
->next
= do_2
;
4218 do_2
->block
->next
= do_3
;
4219 do_3
->block
->next
= assign_matmul
;
4221 var_1
= do_1
->ext
.iterator
->var
;
4222 var_2
= do_2
->ext
.iterator
->var
;
4223 var_3
= do_3
->ext
.iterator
->var
;
4227 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4231 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4235 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4240 u1
= get_size_m1 (matrix_b
, 1);
4241 u2
= get_size_m1 (matrix_a
, 1);
4243 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4244 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4246 do_1
->block
->next
= do_2
;
4247 do_2
->block
->next
= assign_matmul
;
4249 var_1
= do_1
->ext
.iterator
->var
;
4250 var_2
= do_2
->ext
.iterator
->var
;
4253 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4257 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4260 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4265 u1
= get_size_m1 (matrix_b
, 2);
4266 u2
= get_size_m1 (matrix_a
, 1);
4268 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4269 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4271 do_1
->block
->next
= do_2
;
4272 do_2
->block
->next
= assign_matmul
;
4274 var_1
= do_1
->ext
.iterator
->var
;
4275 var_2
= do_2
->ext
.iterator
->var
;
4278 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4281 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4285 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4293 /* Build the conjg call around the variables. Set the typespec manually
4294 because gfc_build_intrinsic_call sometimes gets this wrong. */
4299 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4300 matrix_a
->where
, 1, ascalar
);
4308 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4309 matrix_b
->where
, 1, bscalar
);
4312 /* First loop comes after the zero assignment. */
4313 assign_zero
->next
= do_1
;
4315 /* Build the assignment expression in the loop. */
4316 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4318 mult
= get_operand (op_times
, ascalar
, bscalar
);
4319 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4321 /* If we don't want to keep the original statement around in
4322 the else branch, we can free it. */
4324 if (if_limit
== NULL
)
4325 gfc_free_statements(co
);
4329 gfc_free_expr (zero
);
4334 /* Change matmul function calls in the form of
4338 to the corresponding call to a BLAS routine, if applicable. */
4341 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4342 void *data ATTRIBUTE_UNUSED
)
4344 gfc_code
*co
, *co_next
;
4345 gfc_expr
*expr1
, *expr2
;
4346 gfc_expr
*matrix_a
, *matrix_b
;
4347 gfc_code
*if_limit
= NULL
;
4348 gfc_actual_arglist
*a
, *b
;
4349 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4351 const char *blas_name
;
4352 const char *transa
, *transb
;
4353 gfc_expr
*c1
, *c2
, *b1
;
4354 gfc_actual_arglist
*actual
, *next
;
4357 enum matrix_case m_case
;
4359 gfc_code
**next_code_point
;
4361 /* Many of the tests for inline matmul also apply here. */
4365 if (co
->op
!= EXEC_ASSIGN
)
4368 if (in_where
|| in_assoc_list
)
4371 /* The BLOCKS generated for the temporary variables and FORALL don't
4373 if (forall_level
> 0)
4376 /* For now don't do anything in OpenMP workshare, it confuses
4377 its translation, which expects only the allowed statements in there. */
4379 if (in_omp_workshare
)
4384 if (expr2
->expr_type
!= EXPR_FUNCTION
4385 || expr2
->value
.function
.isym
== NULL
4386 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4389 type
= expr2
->ts
.type
;
4390 kind
= expr2
->ts
.kind
;
4392 /* Guard against recursion. */
4394 if (expr2
->external_blas
)
4397 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4400 if (type
== BT_REAL
)
4403 blas_name
= "sgemm";
4405 blas_name
= "dgemm";
4409 else if (type
== BT_COMPLEX
)
4412 blas_name
= "cgemm";
4414 blas_name
= "zgemm";
4421 a
= expr2
->value
.function
.actual
;
4422 if (a
->expr
->rank
!= 2)
4426 if (b
->expr
->rank
!= 2)
4429 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4430 if (matrix_a
== NULL
)
4443 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4444 if (matrix_b
== NULL
)
4473 inserted_block
= NULL
;
4474 changed_statement
= NULL
;
4476 expr2
->external_blas
= 1;
4478 /* We do not handle data dependencies yet. */
4479 if (gfc_check_dependency (expr1
, matrix_a
, true)
4480 || gfc_check_dependency (expr1
, matrix_b
, true))
4483 /* Generate the if statement and hang it into the tree. */
4484 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4486 (*current_code
) = if_limit
;
4488 if_limit
->block
->next
= co
;
4490 call
= XCNEW (gfc_code
);
4491 call
->loc
= co
->loc
;
4493 /* Bounds checking - a bit simpler than for inlining since we only
4494 have to take care of two-dimensional arrays here. */
4496 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4497 next_code_point
= &(if_limit
->block
->block
->next
);
4499 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4502 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4503 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4507 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4508 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4509 test
= runtime_error_ne (b1
, a2
, B_ERROR_1
);
4510 *next_code_point
= test
;
4511 next_code_point
= &test
->next
;
4515 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4516 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4517 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4518 *next_code_point
= test
;
4519 next_code_point
= &test
->next
;
4521 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4522 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4523 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4524 *next_code_point
= test
;
4525 next_code_point
= &test
->next
;
4531 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4532 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4533 /* matrix_b is transposed, hence dimension 1 for the error message. */
4534 test
= runtime_error_ne (b2
, a2
, B_ERROR_1
);
4535 *next_code_point
= test
;
4536 next_code_point
= &test
->next
;
4540 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4541 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4542 test
= runtime_error_ne (c1
, a1
, C_ERROR_1
);
4543 *next_code_point
= test
;
4544 next_code_point
= &test
->next
;
4546 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4547 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4548 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4549 *next_code_point
= test
;
4550 next_code_point
= &test
->next
;
4556 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4557 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4558 test
= runtime_error_ne (b1
, a1
, B_ERROR_1
);
4559 *next_code_point
= test
;
4560 next_code_point
= &test
->next
;
4564 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4565 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4566 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4567 *next_code_point
= test
;
4568 next_code_point
= &test
->next
;
4570 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4571 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4572 test
= runtime_error_ne (c2
, b2
, C_ERROR_2
);
4573 *next_code_point
= test
;
4574 next_code_point
= &test
->next
;
4579 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4580 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4581 test
= runtime_error_ne (b2
, a1
, B_ERROR_1
);
4582 *next_code_point
= test
;
4583 next_code_point
= &test
->next
;
4587 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4588 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4589 test
= runtime_error_ne (c1
, a2
, C_ERROR_1
);
4590 *next_code_point
= test
;
4591 next_code_point
= &test
->next
;
4593 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4594 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4595 test
= runtime_error_ne (c2
, b1
, C_ERROR_2
);
4596 *next_code_point
= test
;
4597 next_code_point
= &test
->next
;
4606 /* Handle the reallocation, if needed. */
4610 gfc_code
*lhs_alloc
;
4612 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4613 *next_code_point
= lhs_alloc
;
4614 next_code_point
= &lhs_alloc
->next
;
4617 *next_code_point
= call
;
4618 if_limit
->next
= co_next
;
4620 /* Set up the BLAS call. */
4622 call
->op
= EXEC_CALL
;
4624 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4625 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4626 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4627 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4628 call
->resolved_sym
= call
->symtree
->n
.sym
;
4630 /* Argument TRANSA. */
4631 next
= gfc_get_actual_arglist ();
4632 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4635 call
->ext
.actual
= next
;
4637 /* Argument TRANSB. */
4639 next
= gfc_get_actual_arglist ();
4640 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4642 actual
->next
= next
;
4644 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4645 gfc_integer_4_kind
);
4646 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4647 gfc_integer_4_kind
);
4649 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4650 gfc_integer_4_kind
);
4654 next
= gfc_get_actual_arglist ();
4656 actual
->next
= next
;
4660 next
= gfc_get_actual_arglist ();
4662 actual
->next
= next
;
4666 next
= gfc_get_actual_arglist ();
4668 actual
->next
= next
;
4670 /* Argument ALPHA - set to one. */
4672 next
= gfc_get_actual_arglist ();
4673 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4674 if (type
== BT_REAL
)
4675 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4677 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4678 actual
->next
= next
;
4682 next
= gfc_get_actual_arglist ();
4683 next
->expr
= gfc_copy_expr (matrix_a
);
4684 actual
->next
= next
;
4688 next
= gfc_get_actual_arglist ();
4689 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4690 1, gfc_integer_4_kind
);
4691 actual
->next
= next
;
4695 next
= gfc_get_actual_arglist ();
4696 next
->expr
= gfc_copy_expr (matrix_b
);
4697 actual
->next
= next
;
4701 next
= gfc_get_actual_arglist ();
4702 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4703 1, gfc_integer_4_kind
);
4704 actual
->next
= next
;
4706 /* Argument BETA - set to zero. */
4708 next
= gfc_get_actual_arglist ();
4709 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4710 if (type
== BT_REAL
)
4711 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4713 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4714 actual
->next
= next
;
4719 next
= gfc_get_actual_arglist ();
4720 next
->expr
= gfc_copy_expr (expr1
);
4721 actual
->next
= next
;
4725 next
= gfc_get_actual_arglist ();
4726 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4727 1, gfc_integer_4_kind
);
4728 actual
->next
= next
;
4734 /* Code for index interchange for loops which are grouped together in DO
4735 CONCURRENT or FORALL statements. This is currently only applied if the
4736 iterations are grouped together in a single statement.
4738 For this transformation, it is assumed that memory access in strides is
4739 expensive, and that loops which access later indices (which access memory
4740 in bigger strides) should be moved to the first loops.
4742 For this, a loop over all the statements is executed, counting the times
4743 that the loop iteration values are accessed in each index. The loop
4744 indices are then sorted to minimize access to later indices from inner
4747 /* Type for holding index information. */
4751 gfc_forall_iterator
*fa
;
4753 int n
[GFC_MAX_DIMENSIONS
];
4756 /* Callback function to determine if an expression is the
4757 corresponding variable. */
4760 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4762 gfc_expr
*expr
= *e
;
4765 if (expr
->expr_type
!= EXPR_VARIABLE
)
4768 sym
= (gfc_symbol
*) data
;
4769 return sym
== expr
->symtree
->n
.sym
;
4772 /* Callback function to calculate the cost of a certain index. */
4775 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4785 if (expr
->expr_type
!= EXPR_VARIABLE
)
4789 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4791 if (ref
->type
== REF_ARRAY
)
4797 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4800 ind
= (ind_type
*) data
;
4801 for (i
= 0; i
< ar
->dimen
; i
++)
4803 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4805 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4812 /* Callback function for qsort, to sort the loop indices. */
4815 loop_comp (const void *e1
, const void *e2
)
4817 const ind_type
*i1
= (const ind_type
*) e1
;
4818 const ind_type
*i2
= (const ind_type
*) e2
;
4821 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4823 if (i1
->n
[i
] != i2
->n
[i
])
4824 return i1
->n
[i
] - i2
->n
[i
];
4826 /* All other things being equal, let's not change the ordering. */
4827 return i2
->num
- i1
->num
;
4830 /* Main function to do the index interchange. */
4833 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4834 void *data ATTRIBUTE_UNUSED
)
4839 gfc_forall_iterator
*fa
;
4843 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4847 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4850 /* Nothing to reorder. */
4854 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4857 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4859 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4861 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4866 ind
[n_iter
].sym
= NULL
;
4867 ind
[n_iter
].fa
= NULL
;
4869 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4870 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4872 /* Do the actual index interchange. */
4873 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4874 for (i
=1; i
<n_iter
; i
++)
4876 fa
->next
= ind
[i
].fa
;
4881 if (flag_warn_frontend_loop_interchange
)
4883 for (i
=1; i
<n_iter
; i
++)
4885 if (ind
[i
-1].num
> ind
[i
].num
)
4887 gfc_warning (OPT_Wfrontend_loop_interchange
,
4888 "Interchanging loops at %L", &co
->loc
);
4897 #define WALK_SUBEXPR(NODE) \
4900 result = gfc_expr_walker (&(NODE), exprfn, data); \
4905 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4907 /* Walk expression *E, calling EXPRFN on each expression in it. */
4910 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4914 int walk_subtrees
= 1;
4915 gfc_actual_arglist
*a
;
4919 int result
= exprfn (e
, &walk_subtrees
, data
);
4923 switch ((*e
)->expr_type
)
4926 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4927 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4930 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4931 WALK_SUBEXPR (a
->expr
);
4935 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4936 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4937 WALK_SUBEXPR (a
->expr
);
4940 case EXPR_STRUCTURE
:
4942 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4943 c
= gfc_constructor_next (c
))
4945 if (c
->iterator
== NULL
)
4946 WALK_SUBEXPR (c
->expr
);
4950 WALK_SUBEXPR (c
->expr
);
4952 WALK_SUBEXPR (c
->iterator
->var
);
4953 WALK_SUBEXPR (c
->iterator
->start
);
4954 WALK_SUBEXPR (c
->iterator
->end
);
4955 WALK_SUBEXPR (c
->iterator
->step
);
4959 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4962 /* Fall through to the variable case in order to walk the
4966 case EXPR_SUBSTRING
:
4968 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4977 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4979 for (i
=0; i
< ar
->dimen
; i
++)
4981 WALK_SUBEXPR (ar
->start
[i
]);
4982 WALK_SUBEXPR (ar
->end
[i
]);
4983 WALK_SUBEXPR (ar
->stride
[i
]);
4990 WALK_SUBEXPR (r
->u
.ss
.start
);
4991 WALK_SUBEXPR (r
->u
.ss
.end
);
5008 #define WALK_SUBCODE(NODE) \
5011 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5017 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5018 on each expression in it. If any of the hooks returns non-zero, that
5019 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5020 no subcodes or subexpressions are traversed. */
5023 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5026 for (; *c
; c
= &(*c
)->next
)
5028 int walk_subtrees
= 1;
5029 int result
= codefn (c
, &walk_subtrees
, data
);
5036 gfc_actual_arglist
*a
;
5038 gfc_association_list
*alist
;
5039 bool saved_in_omp_workshare
;
5040 bool saved_in_where
;
5042 /* There might be statement insertions before the current code,
5043 which must not affect the expression walker. */
5046 saved_in_omp_workshare
= in_omp_workshare
;
5047 saved_in_where
= in_where
;
5053 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5054 if (co
->ext
.block
.assoc
)
5056 bool saved_in_assoc_list
= in_assoc_list
;
5058 in_assoc_list
= true;
5059 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5060 WALK_SUBEXPR (alist
->target
);
5062 in_assoc_list
= saved_in_assoc_list
;
5069 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5070 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5071 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5072 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5084 case EXEC_ASSIGN_CALL
:
5085 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5086 WALK_SUBEXPR (a
->expr
);
5090 WALK_SUBEXPR (co
->expr1
);
5091 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5092 WALK_SUBEXPR (a
->expr
);
5096 WALK_SUBEXPR (co
->expr1
);
5098 for (b
= co
->block
; b
; b
= b
->block
)
5101 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5103 WALK_SUBEXPR (cp
->low
);
5104 WALK_SUBEXPR (cp
->high
);
5106 WALK_SUBCODE (b
->next
);
5111 case EXEC_DEALLOCATE
:
5114 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5115 WALK_SUBEXPR (a
->expr
);
5120 case EXEC_DO_CONCURRENT
:
5122 gfc_forall_iterator
*fa
;
5123 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5125 WALK_SUBEXPR (fa
->var
);
5126 WALK_SUBEXPR (fa
->start
);
5127 WALK_SUBEXPR (fa
->end
);
5128 WALK_SUBEXPR (fa
->stride
);
5130 if (co
->op
== EXEC_FORALL
)
5136 WALK_SUBEXPR (co
->ext
.open
->unit
);
5137 WALK_SUBEXPR (co
->ext
.open
->file
);
5138 WALK_SUBEXPR (co
->ext
.open
->status
);
5139 WALK_SUBEXPR (co
->ext
.open
->access
);
5140 WALK_SUBEXPR (co
->ext
.open
->form
);
5141 WALK_SUBEXPR (co
->ext
.open
->recl
);
5142 WALK_SUBEXPR (co
->ext
.open
->blank
);
5143 WALK_SUBEXPR (co
->ext
.open
->position
);
5144 WALK_SUBEXPR (co
->ext
.open
->action
);
5145 WALK_SUBEXPR (co
->ext
.open
->delim
);
5146 WALK_SUBEXPR (co
->ext
.open
->pad
);
5147 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5148 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5149 WALK_SUBEXPR (co
->ext
.open
->convert
);
5150 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5151 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5152 WALK_SUBEXPR (co
->ext
.open
->round
);
5153 WALK_SUBEXPR (co
->ext
.open
->sign
);
5154 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5155 WALK_SUBEXPR (co
->ext
.open
->id
);
5156 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5157 WALK_SUBEXPR (co
->ext
.open
->share
);
5158 WALK_SUBEXPR (co
->ext
.open
->cc
);
5162 WALK_SUBEXPR (co
->ext
.close
->unit
);
5163 WALK_SUBEXPR (co
->ext
.close
->status
);
5164 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5165 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5168 case EXEC_BACKSPACE
:
5172 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5173 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5174 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5178 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5179 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5180 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5181 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5182 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5183 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5184 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5185 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5186 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5187 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5188 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5189 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5190 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5191 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5192 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5193 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5194 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5195 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5196 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5197 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5198 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5199 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5200 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5201 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5202 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5203 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5204 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5205 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5206 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5207 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5208 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5209 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5210 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5211 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5212 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5213 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5217 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5218 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5219 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5220 WALK_SUBEXPR (co
->ext
.wait
->id
);
5225 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5226 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5227 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5228 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5229 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5230 WALK_SUBEXPR (co
->ext
.dt
->size
);
5231 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5232 WALK_SUBEXPR (co
->ext
.dt
->id
);
5233 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5234 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5235 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5236 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5237 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5238 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5239 WALK_SUBEXPR (co
->ext
.dt
->round
);
5240 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5241 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5244 case EXEC_OMP_PARALLEL
:
5245 case EXEC_OMP_PARALLEL_DO
:
5246 case EXEC_OMP_PARALLEL_DO_SIMD
:
5247 case EXEC_OMP_PARALLEL_SECTIONS
:
5249 in_omp_workshare
= false;
5251 /* This goto serves as a shortcut to avoid code
5252 duplication or a larger if or switch statement. */
5253 goto check_omp_clauses
;
5255 case EXEC_OMP_WORKSHARE
:
5256 case EXEC_OMP_PARALLEL_WORKSHARE
:
5258 in_omp_workshare
= true;
5262 case EXEC_OMP_CRITICAL
:
5263 case EXEC_OMP_DISTRIBUTE
:
5264 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5265 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5266 case EXEC_OMP_DISTRIBUTE_SIMD
:
5268 case EXEC_OMP_DO_SIMD
:
5269 case EXEC_OMP_ORDERED
:
5270 case EXEC_OMP_SECTIONS
:
5271 case EXEC_OMP_SINGLE
:
5272 case EXEC_OMP_END_SINGLE
:
5274 case EXEC_OMP_TASKLOOP
:
5275 case EXEC_OMP_TASKLOOP_SIMD
:
5276 case EXEC_OMP_TARGET
:
5277 case EXEC_OMP_TARGET_DATA
:
5278 case EXEC_OMP_TARGET_ENTER_DATA
:
5279 case EXEC_OMP_TARGET_EXIT_DATA
:
5280 case EXEC_OMP_TARGET_PARALLEL
:
5281 case EXEC_OMP_TARGET_PARALLEL_DO
:
5282 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5283 case EXEC_OMP_TARGET_SIMD
:
5284 case EXEC_OMP_TARGET_TEAMS
:
5285 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5286 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5287 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5288 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5289 case EXEC_OMP_TARGET_UPDATE
:
5291 case EXEC_OMP_TEAMS
:
5292 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5293 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5294 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5295 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5297 /* Come to this label only from the
5298 EXEC_OMP_PARALLEL_* cases above. */
5302 if (co
->ext
.omp_clauses
)
5304 gfc_omp_namelist
*n
;
5305 static int list_types
[]
5306 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5307 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5309 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5310 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5311 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5312 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5313 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5314 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5315 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5316 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5317 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5318 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5319 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5320 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5321 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5322 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5323 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5324 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5326 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5328 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5330 WALK_SUBEXPR (n
->expr
);
5337 WALK_SUBEXPR (co
->expr1
);
5338 WALK_SUBEXPR (co
->expr2
);
5339 WALK_SUBEXPR (co
->expr3
);
5340 WALK_SUBEXPR (co
->expr4
);
5341 for (b
= co
->block
; b
; b
= b
->block
)
5343 WALK_SUBEXPR (b
->expr1
);
5344 WALK_SUBEXPR (b
->expr2
);
5345 WALK_SUBCODE (b
->next
);
5348 if (co
->op
== EXEC_FORALL
)
5351 if (co
->op
== EXEC_DO
)
5354 if (co
->op
== EXEC_IF
)
5357 if (co
->op
== EXEC_SELECT
)
5360 in_omp_workshare
= saved_in_omp_workshare
;
5361 in_where
= saved_in_where
;
5367 /* As a post-resolution step, check that all global symbols which are
5368 not declared in the source file match in their call signatures.
5369 We do this by looping over the code (and expressions). The first call
5370 we happen to find is assumed to be canonical. */
5373 /* Common tests for argument checking for both functions and subroutines. */
5376 check_externals_procedure (gfc_symbol
*sym
, locus
*loc
,
5377 gfc_actual_arglist
*actual
)
5380 gfc_symbol
*def_sym
= NULL
;
5382 if (sym
== NULL
|| sym
->attr
.is_bind_c
)
5385 if (sym
->attr
.proc
!= PROC_EXTERNAL
&& sym
->attr
.proc
!= PROC_UNKNOWN
)
5388 if (sym
->attr
.if_source
== IFSRC_IFBODY
|| sym
->attr
.if_source
== IFSRC_DECL
)
5391 gsym
= gfc_find_gsymbol (gfc_gsym_root
, sym
->name
);
5396 gfc_find_symbol (sym
->name
, gsym
->ns
, 0, &def_sym
);
5400 gfc_compare_actual_formal (&actual
, def_sym
->formal
, 0, 0, 0, loc
);
5404 /* First time we have seen this procedure called. Let's create an
5405 "interface" from the call and put it into a new namespace. */
5406 gfc_namespace
*save_ns
;
5407 gfc_symbol
*new_sym
;
5410 save_ns
= gfc_current_ns
;
5411 gsym
->ns
= gfc_get_namespace (gfc_current_ns
, 0);
5412 gsym
->ns
->proc_name
= sym
;
5414 gfc_get_symbol (sym
->name
, gsym
->ns
, &new_sym
);
5415 gcc_assert (new_sym
);
5416 new_sym
->attr
= sym
->attr
;
5417 new_sym
->attr
.if_source
= IFSRC_DECL
;
5418 gfc_current_ns
= gsym
->ns
;
5420 gfc_get_formal_from_actual_arglist (new_sym
, actual
);
5421 gfc_current_ns
= save_ns
;
5427 /* Callback for calls of external routines. */
5430 check_externals_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5431 void *data ATTRIBUTE_UNUSED
)
5436 gfc_actual_arglist
*actual
;
5438 if (co
->op
!= EXEC_CALL
)
5441 sym
= co
->resolved_sym
;
5443 actual
= co
->ext
.actual
;
5445 return check_externals_procedure (sym
, loc
, actual
);
5449 /* Callback for external functions. */
5452 check_externals_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
5453 void *data ATTRIBUTE_UNUSED
)
5458 gfc_actual_arglist
*actual
;
5460 if (e
->expr_type
!= EXPR_FUNCTION
)
5463 sym
= e
->value
.function
.esym
;
5468 actual
= e
->value
.function
.actual
;
5470 return check_externals_procedure (sym
, loc
, actual
);
5473 /* Called routine. */
5476 gfc_check_externals (gfc_namespace
*ns
)
5481 /* Turn errors into warnings if the user indicated this. */
5483 if (!pedantic
&& flag_allow_argument_mismatch
)
5484 gfc_errors_to_warnings (true);
5486 gfc_code_walker (&ns
->code
, check_externals_code
, check_externals_expr
, NULL
);
5488 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
5490 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
5491 gfc_check_externals (ns
);
5494 gfc_errors_to_warnings (false);