1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2017 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static bool has_dimen_vector_ref (gfc_expr
*);
57 static int matmul_temp_args (gfc_code
**, int *,void *data
);
60 static void check_locus (gfc_namespace
*);
63 /* How deep we are inside an argument list. */
65 static int count_arglist
;
67 /* Vector of gfc_expr ** we operate on. */
69 static vec
<gfc_expr
**> expr_array
;
71 /* Pointer to the gfc_code we currently work on - to be able to insert
72 a block before the statement. */
74 static gfc_code
**current_code
;
76 /* Pointer to the block to be inserted, and the statement we are
77 changing within the block. */
79 static gfc_code
*inserted_block
, **changed_statement
;
81 /* The namespace we are currently dealing with. */
83 static gfc_namespace
*current_ns
;
85 /* If we are within any forall loop. */
87 static int forall_level
;
89 /* Keep track of whether we are within an OMP workshare. */
91 static bool in_omp_workshare
;
93 /* Keep track of whether we are within a WHERE statement. */
97 /* Keep track of iterators for array constructors. */
99 static int iterator_level
;
101 /* Keep track of DO loop levels. */
109 static vec
<do_t
> doloop_list
;
110 static int doloop_level
;
112 /* Keep track of if and select case levels. */
115 static int select_level
;
117 /* Vector of gfc_expr * to keep track of DO loops. */
119 struct my_struct
*evec
;
121 /* Keep track of association lists. */
123 static bool in_assoc_list
;
125 /* Counter for temporary variables. */
127 static int var_num
= 1;
129 /* What sort of matrix we are dealing with when inlining MATMUL. */
131 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
133 /* Keep track of the number of expressions we have inserted so far
138 /* Entry point - run all passes for a namespace. */
141 gfc_run_passes (gfc_namespace
*ns
)
144 /* Warn about dubious DO loops where the index might
151 doloop_list
.release ();
158 if (flag_frontend_optimize
)
160 optimize_namespace (ns
);
161 optimize_reduction (ns
);
162 if (flag_dump_fortran_optimized
)
163 gfc_dump_parse_tree (ns
, stdout
);
165 expr_array
.release ();
168 gfc_get_errors (&w
, &e
);
172 if (flag_realloc_lhs
)
173 realloc_strings (ns
);
178 /* Callback function: Warn if there is no location information in a
182 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
183 void *data ATTRIBUTE_UNUSED
)
186 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
187 gfc_warning_internal (0, "No location in statement");
193 /* Callback function: Warn if there is no location information in an
197 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
198 void *data ATTRIBUTE_UNUSED
)
201 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
202 gfc_warning_internal (0, "No location in expression near %L",
203 &((*current_code
)->loc
));
207 /* Run check for missing location information. */
210 check_locus (gfc_namespace
*ns
)
212 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
214 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
216 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
223 /* Callback for each gfc_code node invoked from check_realloc_strings.
224 For an allocatable LHS string which also appears as a variable on
236 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
237 void *data ATTRIBUTE_UNUSED
)
239 gfc_expr
*expr1
, *expr2
;
245 if (co
->op
!= EXEC_ASSIGN
)
249 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
250 || !gfc_expr_attr(expr1
).allocatable
251 || !expr1
->ts
.deferred
)
254 expr2
= gfc_discard_nops (co
->expr2
);
256 if (expr2
->expr_type
== EXPR_VARIABLE
)
258 found_substr
= false;
259 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
261 if (ref
->type
== REF_SUBSTRING
)
270 else if (expr2
->expr_type
!= EXPR_OP
271 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
)
274 if (!gfc_check_dependency (expr1
, expr2
, true))
277 /* gfc_check_dependency doesn't always pick up identical expressions.
278 However, eliminating the above sends the compiler into an infinite
279 loop on valid expressions. Without this check, the gimplifier emits
280 an ICE for a = a, where a is deferred character length. */
281 if (!gfc_dep_compare_expr (expr1
, expr2
))
285 inserted_block
= NULL
;
286 changed_statement
= NULL
;
287 n
= create_var (expr2
, "realloc_string");
292 /* Callback for each gfc_code node invoked through gfc_code_walker
293 from optimize_namespace. */
296 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
297 void *data ATTRIBUTE_UNUSED
)
304 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
305 || op
== EXEC_CALL_PPC
)
311 inserted_block
= NULL
;
312 changed_statement
= NULL
;
314 if (op
== EXEC_ASSIGN
)
315 optimize_assignment (*c
);
319 /* Callback for each gfc_expr node invoked through gfc_code_walker
320 from optimize_namespace. */
323 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
324 void *data ATTRIBUTE_UNUSED
)
328 if ((*e
)->expr_type
== EXPR_FUNCTION
)
331 function_expr
= true;
334 function_expr
= false;
336 if (optimize_trim (*e
))
337 gfc_simplify_expr (*e
, 0);
339 if (optimize_lexical_comparison (*e
))
340 gfc_simplify_expr (*e
, 0);
342 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
343 gfc_simplify_expr (*e
, 0);
345 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
346 switch ((*e
)->value
.function
.isym
->id
)
348 case GFC_ISYM_MINLOC
:
349 case GFC_ISYM_MAXLOC
:
350 optimize_minmaxloc (e
);
362 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
363 function is a scalar, just copy it; otherwise returns the new element, the
364 old one can be freed. */
367 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
369 gfc_expr
*fcn
, *e
= c
->expr
;
371 fcn
= gfc_copy_expr (e
);
374 gfc_constructor_base newbase
;
376 gfc_constructor
*new_c
;
379 new_expr
= gfc_get_expr ();
380 new_expr
->expr_type
= EXPR_ARRAY
;
381 new_expr
->ts
= e
->ts
;
382 new_expr
->where
= e
->where
;
384 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
385 new_c
->iterator
= c
->iterator
;
386 new_expr
->value
.constructor
= newbase
;
394 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
396 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
397 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
398 fn
->value
.function
.isym
->name
,
399 fn
->where
, 3, fcn
, NULL
, NULL
);
400 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
401 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
402 fn
->value
.function
.isym
->name
,
403 fn
->where
, 2, fcn
, NULL
);
405 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
407 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
413 /* Callback function for optimzation of reductions to scalars. Transform ANY
414 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
415 correspondingly. Handly only the simple cases without MASK and DIM. */
418 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
419 void *data ATTRIBUTE_UNUSED
)
424 gfc_actual_arglist
*a
;
425 gfc_actual_arglist
*dim
;
427 gfc_expr
*res
, *new_expr
;
428 gfc_actual_arglist
*mask
;
432 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
433 || fn
->value
.function
.isym
== NULL
)
436 id
= fn
->value
.function
.isym
->id
;
438 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
439 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
442 a
= fn
->value
.function
.actual
;
444 /* Don't handle MASK or DIM. */
448 if (dim
->expr
!= NULL
)
451 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
454 if ( mask
->expr
!= NULL
)
460 if (arg
->expr_type
!= EXPR_ARRAY
)
469 case GFC_ISYM_PRODUCT
:
470 op
= INTRINSIC_TIMES
;
485 c
= gfc_constructor_first (arg
->value
.constructor
);
487 /* Don't do any simplififcation if we have
488 - no element in the constructor or
489 - only have a single element in the array which contains an
495 res
= copy_walk_reduction_arg (c
, fn
);
497 c
= gfc_constructor_next (c
);
500 new_expr
= gfc_get_expr ();
501 new_expr
->ts
= fn
->ts
;
502 new_expr
->expr_type
= EXPR_OP
;
503 new_expr
->rank
= fn
->rank
;
504 new_expr
->where
= fn
->where
;
505 new_expr
->value
.op
.op
= op
;
506 new_expr
->value
.op
.op1
= res
;
507 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
509 c
= gfc_constructor_next (c
);
512 gfc_simplify_expr (res
, 0);
519 /* Callback function for common function elimination, called from cfe_expr_0.
520 Put all eligible function expressions into expr_array. */
523 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
524 void *data ATTRIBUTE_UNUSED
)
527 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
530 /* We don't do character functions with unknown charlens. */
531 if ((*e
)->ts
.type
== BT_CHARACTER
532 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
533 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
536 /* We don't do function elimination within FORALL statements, it can
537 lead to wrong-code in certain circumstances. */
539 if (forall_level
> 0)
542 /* Function elimination inside an iterator could lead to functions which
543 depend on iterator variables being moved outside. FIXME: We should check
544 if the functions do indeed depend on the iterator variable. */
546 if (iterator_level
> 0)
549 /* If we don't know the shape at compile time, we create an allocatable
550 temporary variable to hold the intermediate result, but only if
551 allocation on assignment is active. */
553 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
556 /* Skip the test for pure functions if -faggressive-function-elimination
558 if ((*e
)->value
.function
.esym
)
560 /* Don't create an array temporary for elemental functions. */
561 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
564 /* Only eliminate potentially impure functions if the
565 user specifically requested it. */
566 if (!flag_aggressive_function_elimination
567 && !(*e
)->value
.function
.esym
->attr
.pure
568 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
572 if ((*e
)->value
.function
.isym
)
574 /* Conversions are handled on the fly by the middle end,
575 transpose during trans-* stages and TRANSFER by the middle end. */
576 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
577 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
578 || gfc_inline_intrinsic_function_p (*e
))
581 /* Don't create an array temporary for elemental functions,
582 as this would be wasteful of memory.
583 FIXME: Create a scalar temporary during scalarization. */
584 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
587 if (!(*e
)->value
.function
.isym
->pure
)
591 expr_array
.safe_push (e
);
595 /* Auxiliary function to check if an expression is a temporary created by
599 is_fe_temp (gfc_expr
*e
)
601 if (e
->expr_type
!= EXPR_VARIABLE
)
604 return e
->symtree
->n
.sym
->attr
.fe_temp
;
607 /* Determine the length of a string, if it can be evaluated as a constant
608 expression. Return a newly allocated gfc_expr or NULL on failure.
609 If the user specified a substring which is potentially longer than
610 the string itself, the string will be padded with spaces, which
614 constant_string_length (gfc_expr
*e
)
624 length
= e
->ts
.u
.cl
->length
;
625 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
626 return gfc_copy_expr(length
);
629 /* Return length of substring, if constant. */
630 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
632 if (ref
->type
== REF_SUBSTRING
633 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
635 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
638 mpz_add_ui (res
->value
.integer
, value
, 1);
644 /* Return length of char symbol, if constant. */
646 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
647 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
648 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
649 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
655 /* Insert a block at the current position unless it has already
656 been inserted; in this case use the one already there. */
658 static gfc_namespace
*
663 /* If the block hasn't already been created, do so. */
664 if (inserted_block
== NULL
)
666 inserted_block
= XCNEW (gfc_code
);
667 inserted_block
->op
= EXEC_BLOCK
;
668 inserted_block
->loc
= (*current_code
)->loc
;
669 ns
= gfc_build_block_ns (current_ns
);
670 inserted_block
->ext
.block
.ns
= ns
;
671 inserted_block
->ext
.block
.assoc
= NULL
;
673 ns
->code
= *current_code
;
675 /* If the statement has a label, make sure it is transferred to
676 the newly created block. */
678 if ((*current_code
)->here
)
680 inserted_block
->here
= (*current_code
)->here
;
681 (*current_code
)->here
= NULL
;
684 inserted_block
->next
= (*current_code
)->next
;
685 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
686 (*current_code
)->next
= NULL
;
687 /* Insert the BLOCK at the right position. */
688 *current_code
= inserted_block
;
689 ns
->parent
= current_ns
;
692 ns
= inserted_block
->ext
.block
.ns
;
697 /* Returns a new expression (a variable) to be used in place of the old one,
698 with an optional assignment statement before the current statement to set
699 the value of the variable. Creates a new BLOCK for the statement if that
700 hasn't already been done and puts the statement, plus the newly created
701 variables, in that block. Special cases: If the expression is constant or
702 a temporary which has already been created, just copy it. */
705 create_var (gfc_expr
* e
, const char *vname
)
707 char name
[GFC_MAX_SYMBOL_LEN
+1];
708 gfc_symtree
*symtree
;
716 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
717 return gfc_copy_expr (e
);
719 ns
= insert_block ();
722 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
724 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
726 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
729 symbol
= symtree
->n
.sym
;
734 symbol
->as
= gfc_get_array_spec ();
735 symbol
->as
->rank
= e
->rank
;
737 if (e
->shape
== NULL
)
739 /* We don't know the shape at compile time, so we use an
741 symbol
->as
->type
= AS_DEFERRED
;
742 symbol
->attr
.allocatable
= 1;
746 symbol
->as
->type
= AS_EXPLICIT
;
747 /* Copy the shape. */
748 for (i
=0; i
<e
->rank
; i
++)
752 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
754 mpz_set_si (p
->value
.integer
, 1);
755 symbol
->as
->lower
[i
] = p
;
757 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
759 mpz_set (q
->value
.integer
, e
->shape
[i
]);
760 symbol
->as
->upper
[i
] = q
;
766 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
770 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
771 length
= constant_string_length (e
);
773 symbol
->ts
.u
.cl
->length
= length
;
776 symbol
->attr
.allocatable
= 1;
781 symbol
->attr
.flavor
= FL_VARIABLE
;
782 symbol
->attr
.referenced
= 1;
783 symbol
->attr
.dimension
= e
->rank
> 0;
784 symbol
->attr
.fe_temp
= 1;
785 gfc_commit_symbol (symbol
);
787 result
= gfc_get_expr ();
788 result
->expr_type
= EXPR_VARIABLE
;
790 result
->ts
.deferred
= deferred
;
791 result
->rank
= e
->rank
;
792 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
793 result
->symtree
= symtree
;
794 result
->where
= e
->where
;
797 result
->ref
= gfc_get_ref ();
798 result
->ref
->type
= REF_ARRAY
;
799 result
->ref
->u
.ar
.type
= AR_FULL
;
800 result
->ref
->u
.ar
.where
= e
->where
;
801 result
->ref
->u
.ar
.dimen
= e
->rank
;
802 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
803 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
804 if (warn_array_temporaries
)
805 gfc_warning (OPT_Warray_temporaries
,
806 "Creating array temporary at %L", &(e
->where
));
809 /* Generate the new assignment. */
810 n
= XCNEW (gfc_code
);
812 n
->loc
= (*current_code
)->loc
;
813 n
->next
= *changed_statement
;
814 n
->expr1
= gfc_copy_expr (result
);
816 *changed_statement
= n
;
822 /* Warn about function elimination. */
825 do_warn_function_elimination (gfc_expr
*e
)
827 if (e
->expr_type
!= EXPR_FUNCTION
)
829 if (e
->value
.function
.esym
)
830 gfc_warning (OPT_Wfunction_elimination
,
831 "Removing call to function %qs at %L",
832 e
->value
.function
.esym
->name
, &(e
->where
));
833 else if (e
->value
.function
.isym
)
834 gfc_warning (OPT_Wfunction_elimination
,
835 "Removing call to function %qs at %L",
836 e
->value
.function
.isym
->name
, &(e
->where
));
838 /* Callback function for the code walker for doing common function
839 elimination. This builds up the list of functions in the expression
840 and goes through them to detect duplicates, which it then replaces
844 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
845 void *data ATTRIBUTE_UNUSED
)
851 /* Don't do this optimization within OMP workshare or ASSOC lists. */
853 if (in_omp_workshare
|| in_assoc_list
)
859 expr_array
.release ();
861 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
863 /* Walk through all the functions. */
865 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
867 /* Skip if the function has been replaced by a variable already. */
868 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
875 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
878 newvar
= create_var (*ei
, "fcn");
880 if (warn_function_elimination
)
881 do_warn_function_elimination (*ej
);
884 *ej
= gfc_copy_expr (newvar
);
891 /* We did all the necessary walking in this function. */
896 /* Callback function for common function elimination, called from
897 gfc_code_walker. This keeps track of the current code, in order
898 to insert statements as needed. */
901 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
904 inserted_block
= NULL
;
905 changed_statement
= NULL
;
907 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
908 and allocation on assigment are prohibited inside WHERE, and finally
909 masking an expression would lead to wrong-code when replacing
912 b = sum(foo(a) + foo(a))
923 if ((*c
)->op
== EXEC_WHERE
)
933 /* Dummy function for expression call back, for use when we
934 really don't want to do any walking. */
937 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
938 void *data ATTRIBUTE_UNUSED
)
944 /* Dummy function for code callback, for use when we really
945 don't want to do anything. */
947 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
948 int *walk_subtrees ATTRIBUTE_UNUSED
,
949 void *data ATTRIBUTE_UNUSED
)
954 /* Code callback function for converting
961 This is because common function elimination would otherwise place the
962 temporary variables outside the loop. */
965 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
966 void *data ATTRIBUTE_UNUSED
)
969 gfc_code
*c_if1
, *c_if2
, *c_exit
;
971 gfc_expr
*e_not
, *e_cond
;
973 if (co
->op
!= EXEC_DO_WHILE
)
976 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
981 /* Generate the condition of the if statement, which is .not. the original
983 e_not
= gfc_get_expr ();
984 e_not
->ts
= e_cond
->ts
;
985 e_not
->where
= e_cond
->where
;
986 e_not
->expr_type
= EXPR_OP
;
987 e_not
->value
.op
.op
= INTRINSIC_NOT
;
988 e_not
->value
.op
.op1
= e_cond
;
990 /* Generate the EXIT statement. */
991 c_exit
= XCNEW (gfc_code
);
992 c_exit
->op
= EXEC_EXIT
;
993 c_exit
->ext
.which_construct
= co
;
994 c_exit
->loc
= co
->loc
;
996 /* Generate the IF statement. */
997 c_if2
= XCNEW (gfc_code
);
999 c_if2
->expr1
= e_not
;
1000 c_if2
->next
= c_exit
;
1001 c_if2
->loc
= co
->loc
;
1003 /* ... plus the one to chain it to. */
1004 c_if1
= XCNEW (gfc_code
);
1005 c_if1
->op
= EXEC_IF
;
1006 c_if1
->block
= c_if2
;
1007 c_if1
->loc
= co
->loc
;
1009 /* Make the DO WHILE loop into a DO block by replacing the condition
1010 with a true constant. */
1011 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1013 /* Hang the generated if statement into the loop body. */
1015 loopblock
= co
->block
->next
;
1016 co
->block
->next
= c_if1
;
1017 c_if1
->next
= loopblock
;
1022 /* Code callback function for converting
1035 because otherwise common function elimination would place the BLOCKs
1036 into the wrong place. */
1039 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1040 void *data ATTRIBUTE_UNUSED
)
1043 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1045 if (co
->op
!= EXEC_IF
)
1048 /* This loop starts out with the first ELSE statement. */
1049 else_stmt
= co
->block
->block
;
1051 while (else_stmt
!= NULL
)
1053 gfc_code
*next_else
;
1055 /* If there is no condition, we're done. */
1056 if (else_stmt
->expr1
== NULL
)
1059 next_else
= else_stmt
->block
;
1061 /* Generate the new IF statement. */
1062 c_if2
= XCNEW (gfc_code
);
1063 c_if2
->op
= EXEC_IF
;
1064 c_if2
->expr1
= else_stmt
->expr1
;
1065 c_if2
->next
= else_stmt
->next
;
1066 c_if2
->loc
= else_stmt
->loc
;
1067 c_if2
->block
= next_else
;
1069 /* ... plus the one to chain it to. */
1070 c_if1
= XCNEW (gfc_code
);
1071 c_if1
->op
= EXEC_IF
;
1072 c_if1
->block
= c_if2
;
1073 c_if1
->loc
= else_stmt
->loc
;
1075 /* Insert the new IF after the ELSE. */
1076 else_stmt
->expr1
= NULL
;
1077 else_stmt
->next
= c_if1
;
1078 else_stmt
->block
= NULL
;
1080 else_stmt
= next_else
;
1082 /* Don't walk subtrees. */
1088 struct do_stack
*prev
;
1093 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1094 optimize by replacing do loops with their analog array slices. For
1097 write (*,*) (a(i), i=1,4)
1101 write (*,*) a(1:4:1) . */
1104 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1107 gfc_expr
*new_e
, *expr
, *start
;
1109 struct do_stack ds_push
;
1110 int i
, future_rank
= 0;
1111 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1114 /* Find the first transfer/do statement. */
1115 for (curr
= code
; curr
; curr
= curr
->next
)
1117 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1121 /* Ensure it is the only transfer/do statement because cases like
1123 write (*,*) (a(i), b(i), i=1,4)
1125 cannot be optimized. */
1127 if (!curr
|| curr
->next
)
1130 if (curr
->op
== EXEC_DO
)
1132 if (curr
->ext
.iterator
->var
->ref
)
1134 ds_push
.prev
= stack_top
;
1135 ds_push
.iter
= curr
->ext
.iterator
;
1136 ds_push
.code
= curr
;
1137 stack_top
= &ds_push
;
1138 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1140 if (curr
!= stack_top
->code
&& !*has_reached
)
1142 curr
->block
->next
= NULL
;
1143 gfc_free_statements (curr
);
1146 *has_reached
= true;
1152 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1154 /* FIXME: Workaround for PR 80945 - array slices with deferred character
1155 lenghts do not work. Remove this section when the PR is fixed. */
1157 if (e
->expr_type
== EXPR_VARIABLE
&& e
->ts
.type
== BT_CHARACTER
1160 /* End of section to be removed. */
1163 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1166 /* Find the iterators belonging to each variable and check conditions. */
1167 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1169 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1170 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1173 start
= ref
->u
.ar
.start
[i
];
1174 gfc_simplify_expr (start
, 0);
1175 switch (start
->expr_type
)
1179 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1183 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1184 if (!stack_top
|| !stack_top
->iter
1185 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1187 /* Check for (a(i,i), i=1,3). */
1191 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1198 iters
[i
] = stack_top
->iter
;
1199 stack_top
= stack_top
->prev
;
1207 switch (start
->value
.op
.op
)
1209 case INTRINSIC_PLUS
:
1210 case INTRINSIC_TIMES
:
1211 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1212 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1214 case INTRINSIC_MINUS
:
1215 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1216 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1217 || start
->value
.op
.op1
->ref
)
1219 if (!stack_top
|| !stack_top
->iter
1220 || stack_top
->iter
->var
->symtree
1221 != start
->value
.op
.op1
->symtree
)
1223 iters
[i
] = stack_top
->iter
;
1224 stack_top
= stack_top
->prev
;
1236 /* Create new expr. */
1237 new_e
= gfc_copy_expr (curr
->expr1
);
1238 new_e
->expr_type
= EXPR_VARIABLE
;
1239 new_e
->rank
= future_rank
;
1240 if (curr
->expr1
->shape
)
1241 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1243 /* Assign new starts, ends and strides if necessary. */
1244 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1248 start
= ref
->u
.ar
.start
[i
];
1249 switch (start
->expr_type
)
1252 gfc_internal_error ("bad expression");
1255 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1256 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1257 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1258 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1259 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1260 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1263 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1264 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1265 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1266 expr
= gfc_copy_expr (start
);
1267 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1268 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1269 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1270 expr
= gfc_copy_expr (start
);
1271 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1272 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1273 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1274 switch (start
->value
.op
.op
)
1276 case INTRINSIC_MINUS
:
1277 case INTRINSIC_PLUS
:
1278 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1280 case INTRINSIC_TIMES
:
1281 expr
= gfc_copy_expr (start
);
1282 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1283 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1284 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1287 gfc_internal_error ("bad op");
1291 gfc_internal_error ("bad expression");
1294 curr
->expr1
= new_e
;
1296 /* Insert modified statement. Check whether the statement needs to be
1297 inserted at the lowest level. */
1298 if (!stack_top
->iter
)
1302 curr
->next
= prev
->next
->next
;
1307 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1308 stack_top
->code
->block
->next
= curr
;
1312 stack_top
->code
->block
->next
= curr
;
1316 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1317 tries to optimize its block. */
1320 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1321 void *data ATTRIBUTE_UNUSED
)
1323 gfc_code
**curr
, *prev
= NULL
;
1324 struct do_stack write
, first
;
1328 || ((*code
)->block
->op
!= EXEC_WRITE
1329 && (*code
)->block
->op
!= EXEC_READ
))
1337 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1339 if ((*curr
)->op
== EXEC_DO
)
1341 first
.prev
= &write
;
1342 first
.iter
= (*curr
)->ext
.iterator
;
1345 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1353 /* Optimize a namespace, including all contained namespaces. */
1356 optimize_namespace (gfc_namespace
*ns
)
1358 gfc_namespace
*saved_ns
= gfc_current_ns
;
1360 gfc_current_ns
= ns
;
1363 in_assoc_list
= false;
1364 in_omp_workshare
= false;
1366 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1367 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1368 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1369 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1370 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1371 if (flag_inline_matmul_limit
!= 0)
1377 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1382 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1384 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1388 /* BLOCKs are handled in the expression walker below. */
1389 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1391 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1392 optimize_namespace (ns
);
1394 gfc_current_ns
= saved_ns
;
1397 /* Handle dependencies for allocatable strings which potentially redefine
1398 themselves in an assignment. */
1401 realloc_strings (gfc_namespace
*ns
)
1404 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1406 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1408 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1409 realloc_strings (ns
);
1415 optimize_reduction (gfc_namespace
*ns
)
1418 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1419 callback_reduction
, NULL
);
1421 /* BLOCKs are handled in the expression walker below. */
1422 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1424 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1425 optimize_reduction (ns
);
1429 /* Replace code like
1432 a = matmul(b,c) ; a = a + d
1433 where the array function is not elemental and not allocatable
1434 and does not depend on the left-hand side.
1438 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1446 if (e
->expr_type
== EXPR_OP
)
1448 switch (e
->value
.op
.op
)
1450 /* Unary operators and exponentiation: Only look at a single
1453 case INTRINSIC_UPLUS
:
1454 case INTRINSIC_UMINUS
:
1455 case INTRINSIC_PARENTHESES
:
1456 case INTRINSIC_POWER
:
1457 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1461 case INTRINSIC_CONCAT
:
1462 /* Do not do string concatenations. */
1466 /* Binary operators. */
1467 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1470 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1476 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1477 && ! (e
->value
.function
.esym
1478 && (e
->value
.function
.esym
->attr
.elemental
1479 || e
->value
.function
.esym
->attr
.allocatable
1480 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1481 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1482 && ! (e
->value
.function
.isym
1483 && (e
->value
.function
.isym
->elemental
1484 || e
->ts
.type
!= c
->expr1
->ts
.type
1485 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1486 && ! gfc_inline_intrinsic_function_p (e
))
1492 /* Insert a new assignment statement after the current one. */
1493 n
= XCNEW (gfc_code
);
1494 n
->op
= EXEC_ASSIGN
;
1499 n
->expr1
= gfc_copy_expr (c
->expr1
);
1500 n
->expr2
= c
->expr2
;
1501 new_expr
= gfc_copy_expr (c
->expr1
);
1509 /* Nothing to optimize. */
1513 /* Remove unneeded TRIMs at the end of expressions. */
1516 remove_trim (gfc_expr
*rhs
)
1524 /* Check for a // b // trim(c). Looping is probably not
1525 necessary because the parser usually generates
1526 (// (// a b ) trim(c) ) , but better safe than sorry. */
1528 while (rhs
->expr_type
== EXPR_OP
1529 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1530 rhs
= rhs
->value
.op
.op2
;
1532 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1533 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1535 strip_function_call (rhs
);
1536 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1544 /* Optimizations for an assignment. */
1547 optimize_assignment (gfc_code
* c
)
1549 gfc_expr
*lhs
, *rhs
;
1554 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1556 /* Optimize a = trim(b) to a = b. */
1559 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1560 if (is_empty_string (rhs
))
1561 rhs
->value
.character
.length
= 0;
1564 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1565 optimize_binop_array_assignment (c
, &rhs
, false);
1569 /* Remove an unneeded function call, modifying the expression.
1570 This replaces the function call with the value of its
1571 first argument. The rest of the argument list is freed. */
1574 strip_function_call (gfc_expr
*e
)
1577 gfc_actual_arglist
*a
;
1579 a
= e
->value
.function
.actual
;
1581 /* We should have at least one argument. */
1582 gcc_assert (a
->expr
!= NULL
);
1586 /* Free the remaining arglist, if any. */
1588 gfc_free_actual_arglist (a
->next
);
1590 /* Graft the argument expression onto the original function. */
1596 /* Optimization of lexical comparison functions. */
1599 optimize_lexical_comparison (gfc_expr
*e
)
1601 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1604 switch (e
->value
.function
.isym
->id
)
1607 return optimize_comparison (e
, INTRINSIC_LE
);
1610 return optimize_comparison (e
, INTRINSIC_GE
);
1613 return optimize_comparison (e
, INTRINSIC_GT
);
1616 return optimize_comparison (e
, INTRINSIC_LT
);
1624 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1625 do CHARACTER because of possible pessimization involving character
1629 combine_array_constructor (gfc_expr
*e
)
1632 gfc_expr
*op1
, *op2
;
1635 gfc_constructor
*c
, *new_c
;
1636 gfc_constructor_base oldbase
, newbase
;
1639 /* Array constructors have rank one. */
1643 /* Don't try to combine association lists, this makes no sense
1644 and leads to an ICE. */
1648 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1649 if (forall_level
> 0)
1652 /* Inside an iterator, things can get hairy; we are likely to create
1653 an invalid temporary variable. */
1654 if (iterator_level
> 0)
1657 op1
= e
->value
.op
.op1
;
1658 op2
= e
->value
.op
.op2
;
1663 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1664 scalar_first
= false;
1665 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1667 scalar_first
= true;
1668 op1
= e
->value
.op
.op2
;
1669 op2
= e
->value
.op
.op1
;
1674 if (op2
->ts
.type
== BT_CHARACTER
)
1677 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1679 oldbase
= op1
->value
.constructor
;
1681 e
->expr_type
= EXPR_ARRAY
;
1683 for (c
= gfc_constructor_first (oldbase
); c
;
1684 c
= gfc_constructor_next (c
))
1686 new_expr
= gfc_get_expr ();
1687 new_expr
->ts
= e
->ts
;
1688 new_expr
->expr_type
= EXPR_OP
;
1689 new_expr
->rank
= c
->expr
->rank
;
1690 new_expr
->where
= c
->expr
->where
;
1691 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1695 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1696 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1700 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1701 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1704 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1705 new_c
->iterator
= c
->iterator
;
1709 gfc_free_expr (op1
);
1710 gfc_free_expr (op2
);
1711 gfc_free_expr (scalar
);
1713 e
->value
.constructor
= newbase
;
1717 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1718 2**k into ishift(1,k) */
1721 optimize_power (gfc_expr
*e
)
1723 gfc_expr
*op1
, *op2
;
1724 gfc_expr
*iand
, *ishft
;
1726 if (e
->ts
.type
!= BT_INTEGER
)
1729 op1
= e
->value
.op
.op1
;
1731 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1734 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1736 gfc_free_expr (op1
);
1738 op2
= e
->value
.op
.op2
;
1743 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1744 "_internal_iand", e
->where
, 2, op2
,
1745 gfc_get_int_expr (e
->ts
.kind
,
1748 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1749 "_internal_ishft", e
->where
, 2, iand
,
1750 gfc_get_int_expr (e
->ts
.kind
,
1753 e
->value
.op
.op
= INTRINSIC_MINUS
;
1754 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1755 e
->value
.op
.op2
= ishft
;
1758 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1760 gfc_free_expr (op1
);
1762 op2
= e
->value
.op
.op2
;
1766 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1767 "_internal_ishft", e
->where
, 2,
1768 gfc_get_int_expr (e
->ts
.kind
,
1775 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1777 op2
= e
->value
.op
.op2
;
1781 gfc_free_expr (op1
);
1782 gfc_free_expr (op2
);
1784 e
->expr_type
= EXPR_CONSTANT
;
1785 e
->value
.op
.op1
= NULL
;
1786 e
->value
.op
.op2
= NULL
;
1787 mpz_init_set_si (e
->value
.integer
, 1);
1788 /* Typespec and location are still OK. */
1795 /* Recursive optimization of operators. */
1798 optimize_op (gfc_expr
*e
)
1802 gfc_intrinsic_op op
= e
->value
.op
.op
;
1806 /* Only use new-style comparisons. */
1809 case INTRINSIC_EQ_OS
:
1813 case INTRINSIC_GE_OS
:
1817 case INTRINSIC_LE_OS
:
1821 case INTRINSIC_NE_OS
:
1825 case INTRINSIC_GT_OS
:
1829 case INTRINSIC_LT_OS
:
1845 changed
= optimize_comparison (e
, op
);
1848 /* Look at array constructors. */
1849 case INTRINSIC_PLUS
:
1850 case INTRINSIC_MINUS
:
1851 case INTRINSIC_TIMES
:
1852 case INTRINSIC_DIVIDE
:
1853 return combine_array_constructor (e
) || changed
;
1855 case INTRINSIC_POWER
:
1856 return optimize_power (e
);
1866 /* Return true if a constant string contains only blanks. */
1869 is_empty_string (gfc_expr
*e
)
1873 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1876 for (i
=0; i
< e
->value
.character
.length
; i
++)
1878 if (e
->value
.character
.string
[i
] != ' ')
1886 /* Insert a call to the intrinsic len_trim. Use a different name for
1887 the symbol tree so we don't run into trouble when the user has
1888 renamed len_trim for some reason. */
1891 get_len_trim_call (gfc_expr
*str
, int kind
)
1894 gfc_actual_arglist
*actual_arglist
, *next
;
1896 fcn
= gfc_get_expr ();
1897 fcn
->expr_type
= EXPR_FUNCTION
;
1898 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1899 actual_arglist
= gfc_get_actual_arglist ();
1900 actual_arglist
->expr
= str
;
1901 next
= gfc_get_actual_arglist ();
1902 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1903 actual_arglist
->next
= next
;
1905 fcn
->value
.function
.actual
= actual_arglist
;
1906 fcn
->where
= str
->where
;
1907 fcn
->ts
.type
= BT_INTEGER
;
1908 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1910 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1911 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1912 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1913 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1914 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1915 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1916 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1917 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1922 /* Optimize expressions for equality. */
1925 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1927 gfc_expr
*op1
, *op2
;
1931 gfc_actual_arglist
*firstarg
, *secondarg
;
1933 if (e
->expr_type
== EXPR_OP
)
1937 op1
= e
->value
.op
.op1
;
1938 op2
= e
->value
.op
.op2
;
1940 else if (e
->expr_type
== EXPR_FUNCTION
)
1942 /* One of the lexical comparison functions. */
1943 firstarg
= e
->value
.function
.actual
;
1944 secondarg
= firstarg
->next
;
1945 op1
= firstarg
->expr
;
1946 op2
= secondarg
->expr
;
1951 /* Strip off unneeded TRIM calls from string comparisons. */
1953 change
= remove_trim (op1
);
1955 if (remove_trim (op2
))
1958 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1959 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1960 handles them well). However, there are also cases that need a non-scalar
1961 argument. For example the any intrinsic. See PR 45380. */
1965 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1967 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1968 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1970 bool empty_op1
, empty_op2
;
1971 empty_op1
= is_empty_string (op1
);
1972 empty_op2
= is_empty_string (op2
);
1974 if (empty_op1
|| empty_op2
)
1980 /* This can only happen when an error for comparing
1981 characters of different kinds has already been issued. */
1982 if (empty_op1
&& empty_op2
)
1985 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1986 str
= empty_op1
? op2
: op1
;
1988 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1992 gfc_free_expr (op1
);
1994 gfc_free_expr (op2
);
1998 e
->value
.op
.op1
= fcn
;
1999 e
->value
.op
.op2
= zero
;
2004 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2006 if (flag_finite_math_only
2007 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2008 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2010 eq
= gfc_dep_compare_expr (op1
, op2
);
2013 /* Replace A // B < A // C with B < C, and A // B < C // B
2015 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2016 && op1
->expr_type
== EXPR_OP
2017 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2018 && op2
->expr_type
== EXPR_OP
2019 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2021 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2022 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2023 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2024 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2026 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2028 /* Watch out for 'A ' // x vs. 'A' // x. */
2030 if (op1_left
->expr_type
== EXPR_CONSTANT
2031 && op2_left
->expr_type
== EXPR_CONSTANT
2032 && op1_left
->value
.character
.length
2033 != op2_left
->value
.character
.length
)
2041 firstarg
->expr
= op1_right
;
2042 secondarg
->expr
= op2_right
;
2046 e
->value
.op
.op1
= op1_right
;
2047 e
->value
.op
.op2
= op2_right
;
2049 optimize_comparison (e
, op
);
2053 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2059 firstarg
->expr
= op1_left
;
2060 secondarg
->expr
= op2_left
;
2064 e
->value
.op
.op1
= op1_left
;
2065 e
->value
.op
.op2
= op2_left
;
2068 optimize_comparison (e
, op
);
2075 /* eq can only be -1, 0 or 1 at this point. */
2103 gfc_internal_error ("illegal OP in optimize_comparison");
2107 /* Replace the expression by a constant expression. The typespec
2108 and where remains the way it is. */
2111 e
->expr_type
= EXPR_CONSTANT
;
2112 e
->value
.logical
= result
;
2120 /* Optimize a trim function by replacing it with an equivalent substring
2121 involving a call to len_trim. This only works for expressions where
2122 variables are trimmed. Return true if anything was modified. */
2125 optimize_trim (gfc_expr
*e
)
2130 gfc_ref
**rr
= NULL
;
2132 /* Don't do this optimization within an argument list, because
2133 otherwise aliasing issues may occur. */
2135 if (count_arglist
!= 1)
2138 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2139 || e
->value
.function
.isym
== NULL
2140 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2143 a
= e
->value
.function
.actual
->expr
;
2145 if (a
->expr_type
!= EXPR_VARIABLE
)
2148 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2150 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2153 /* Follow all references to find the correct place to put the newly
2154 created reference. FIXME: Also handle substring references and
2155 array references. Array references cause strange regressions at
2160 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2162 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2167 strip_function_call (e
);
2172 /* Create the reference. */
2174 ref
= gfc_get_ref ();
2175 ref
->type
= REF_SUBSTRING
;
2177 /* Set the start of the reference. */
2179 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
2181 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2183 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
2185 /* Set the end of the reference to the call to len_trim. */
2187 ref
->u
.ss
.end
= fcn
;
2188 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2193 /* Optimize minloc(b), where b is rank 1 array, into
2194 (/ minloc(b, dim=1) /), and similarly for maxloc,
2195 as the latter forms are expanded inline. */
2198 optimize_minmaxloc (gfc_expr
**e
)
2201 gfc_actual_arglist
*a
;
2205 || fn
->value
.function
.actual
== NULL
2206 || fn
->value
.function
.actual
->expr
== NULL
2207 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2210 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2211 (*e
)->shape
= fn
->shape
;
2214 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2216 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2217 strcpy (name
, fn
->value
.function
.name
);
2218 p
= strstr (name
, "loc0");
2220 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2221 if (fn
->value
.function
.actual
->next
)
2223 a
= fn
->value
.function
.actual
->next
;
2224 gcc_assert (a
->expr
== NULL
);
2228 a
= gfc_get_actual_arglist ();
2229 fn
->value
.function
.actual
->next
= a
;
2231 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2233 mpz_set_ui (a
->expr
->value
.integer
, 1);
2236 /* Callback function for code checking that we do not pass a DO variable to an
2237 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2240 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2241 void *data ATTRIBUTE_UNUSED
)
2245 gfc_formal_arglist
*f
;
2246 gfc_actual_arglist
*a
;
2253 /* If the doloop_list grew, we have to truncate it here. */
2255 if ((unsigned) doloop_level
< doloop_list
.length())
2256 doloop_list
.truncate (doloop_level
);
2263 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2268 loop
.branch_level
= if_level
+ select_level
;
2269 loop
.seen_goto
= false;
2270 doloop_list
.safe_push (loop
);
2273 /* If anything could transfer control away from a suspicious
2274 subscript, make sure to set seen_goto in the current DO loop
2279 case EXEC_ERROR_STOP
:
2285 if (co
->ext
.open
->err
)
2290 if (co
->ext
.close
->err
)
2294 case EXEC_BACKSPACE
:
2299 if (co
->ext
.filepos
->err
)
2304 if (co
->ext
.filepos
->err
)
2310 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2315 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2316 loop
.seen_goto
= true;
2321 if (co
->resolved_sym
== NULL
)
2324 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2326 /* Withot a formal arglist, there is only unknown INTENT,
2327 which we don't check for. */
2335 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2343 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2345 if (a
->expr
&& a
->expr
->symtree
2346 && a
->expr
->symtree
->n
.sym
== do_sym
)
2348 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2349 gfc_error_now ("Variable %qs at %L set to undefined "
2350 "value inside loop beginning at %L as "
2351 "INTENT(OUT) argument to subroutine %qs",
2352 do_sym
->name
, &a
->expr
->where
,
2353 &(doloop_list
[i
].c
->loc
),
2354 co
->symtree
->n
.sym
->name
);
2355 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2356 gfc_error_now ("Variable %qs at %L not definable inside "
2357 "loop beginning at %L as INTENT(INOUT) "
2358 "argument to subroutine %qs",
2359 do_sym
->name
, &a
->expr
->where
,
2360 &(doloop_list
[i
].c
->loc
),
2361 co
->symtree
->n
.sym
->name
);
2372 if (seen_goto
&& doloop_level
> 0)
2373 doloop_list
[doloop_level
-1].seen_goto
= true;
2378 /* Callback function to warn about different things within DO loops. */
2381 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2382 void *data ATTRIBUTE_UNUSED
)
2386 if (doloop_list
.length () == 0)
2389 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2392 last
= &doloop_list
.last();
2393 if (last
->seen_goto
&& !warn_do_subscript
)
2396 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2408 /* Callback function - if the expression is the variable in data->sym,
2409 replace it with a constant from data->val. */
2412 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2419 if (ex
->expr_type
!= EXPR_VARIABLE
)
2422 d
= (insert_index_t
*) data
;
2423 if (ex
->symtree
->n
.sym
!= d
->sym
)
2426 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2427 mpz_set (n
->value
.integer
, d
->val
);
2434 /* In the expression e, replace occurrences of the variable sym with
2435 val. If this results in a constant expression, return true and
2436 return the value in ret. Return false if the expression already
2437 is a constant. Caller has to clear ret in that case. */
2440 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2443 insert_index_t data
;
2446 if (e
->expr_type
== EXPR_CONSTANT
)
2449 n
= gfc_copy_expr (e
);
2451 mpz_init_set (data
.val
, val
);
2452 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2453 gfc_simplify_expr (n
, 0);
2455 if (n
->expr_type
== EXPR_CONSTANT
)
2458 mpz_init_set (ret
, n
->value
.integer
);
2463 mpz_clear (data
.val
);
2469 /* Check array subscripts for possible out-of-bounds accesses in DO
2470 loops with constant bounds. */
2473 do_subscript (gfc_expr
**e
)
2483 /* Constants are already checked. */
2484 if (v
->expr_type
== EXPR_CONSTANT
)
2487 /* Wrong warnings will be generated in an associate list. */
2491 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2493 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2496 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2499 mpz_t do_start
, do_step
, do_end
;
2500 bool have_do_start
, have_do_end
;
2501 bool error_not_proven
;
2508 /* If we are within a branch, or a goto or equivalent
2509 was seen in the DO loop before, then we cannot prove that
2510 this expression is actually evaluated. Don't do anything
2511 unless we want to see it all. */
2512 error_not_proven
= lp
->seen_goto
2513 || lp
->branch_level
< if_level
+ select_level
;
2515 if (error_not_proven
&& !warn_do_subscript
)
2518 if (error_not_proven
)
2519 warn
= OPT_Wdo_subscript
;
2523 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2524 if (do_sym
->ts
.type
!= BT_INTEGER
)
2527 /* If we do not know about the stepsize, the loop may be zero trip.
2528 Do not warn in this case. */
2530 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2531 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2535 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2537 have_do_start
= true;
2538 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2541 have_do_start
= false;
2544 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2547 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2550 have_do_end
= false;
2552 if (!have_do_start
&& !have_do_end
)
2555 /* May have to correct the end value if the step does not equal
2557 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2563 mpz_sub (diff
, do_end
, do_start
);
2564 mpz_tdiv_r (rem
, diff
, do_step
);
2565 mpz_sub (do_end
, do_end
, rem
);
2570 for (i
= 0; i
< ar
->dimen
; i
++)
2573 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2574 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2576 if (ar
->as
->lower
[i
]
2577 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2578 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2579 gfc_warning (warn
, "Array reference at %L out of bounds "
2580 "(%ld < %ld) in loop beginning at %L",
2581 &ar
->start
[i
]->where
, mpz_get_si (val
),
2582 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2583 &doloop_list
[j
].c
->loc
);
2585 if (ar
->as
->upper
[i
]
2586 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2587 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2588 gfc_warning (warn
, "Array reference at %L out of bounds "
2589 "(%ld > %ld) in loop beginning at %L",
2590 &ar
->start
[i
]->where
, mpz_get_si (val
),
2591 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2592 &doloop_list
[j
].c
->loc
);
2597 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2598 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2600 if (ar
->as
->lower
[i
]
2601 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2602 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2603 gfc_warning (warn
, "Array reference at %L out of bounds "
2604 "(%ld < %ld) in loop beginning at %L",
2605 &ar
->start
[i
]->where
, mpz_get_si (val
),
2606 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2607 &doloop_list
[j
].c
->loc
);
2609 if (ar
->as
->upper
[i
]
2610 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2611 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2612 gfc_warning (warn
, "Array reference at %L out of bounds "
2613 "(%ld > %ld) in loop beginning at %L",
2614 &ar
->start
[i
]->where
, mpz_get_si (val
),
2615 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2616 &doloop_list
[j
].c
->loc
);
2626 /* Function for functions checking that we do not pass a DO variable
2627 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2630 do_intent (gfc_expr
**e
)
2632 gfc_formal_arglist
*f
;
2633 gfc_actual_arglist
*a
;
2640 if (expr
->expr_type
!= EXPR_FUNCTION
)
2643 /* Intrinsic functions don't modify their arguments. */
2645 if (expr
->value
.function
.isym
)
2648 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2650 /* Without a formal arglist, there is only unknown INTENT,
2651 which we don't check for. */
2655 a
= expr
->value
.function
.actual
;
2659 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2666 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2668 if (a
->expr
&& a
->expr
->symtree
2669 && a
->expr
->symtree
->n
.sym
== do_sym
)
2671 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2672 gfc_error_now ("Variable %qs at %L set to undefined value "
2673 "inside loop beginning at %L as INTENT(OUT) "
2674 "argument to function %qs", do_sym
->name
,
2675 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2676 expr
->symtree
->n
.sym
->name
);
2677 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2678 gfc_error_now ("Variable %qs at %L not definable inside loop"
2679 " beginning at %L as INTENT(INOUT) argument to"
2680 " function %qs", do_sym
->name
,
2681 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2682 expr
->symtree
->n
.sym
->name
);
2693 doloop_warn (gfc_namespace
*ns
)
2695 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2698 /* This selction deals with inlining calls to MATMUL. */
2700 /* Replace calls to matmul outside of straight assignments with a temporary
2701 variable so that later inlining will work. */
2704 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2708 bool *found
= (bool *) data
;
2712 if (e
->expr_type
!= EXPR_FUNCTION
2713 || e
->value
.function
.isym
== NULL
2714 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2717 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2721 /* Check if this is already in the form c = matmul(a,b). */
2723 if ((*current_code
)->expr2
== e
)
2726 n
= create_var (e
, "matmul");
2728 /* If create_var is unable to create a variable (for example if
2729 -fno-realloc-lhs is in force with a variable that does not have bounds
2730 known at compile-time), just return. */
2740 /* Set current_code and associated variables so that matmul_to_var_expr can
2744 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2745 void *data ATTRIBUTE_UNUSED
)
2747 if (current_code
!= c
)
2750 inserted_block
= NULL
;
2751 changed_statement
= NULL
;
2758 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2759 for a and b if there is a dependency between the arguments and the
2760 result variable or if a or b are the result of calculations that cannot
2761 be handled by the inliner. */
2764 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2765 void *data ATTRIBUTE_UNUSED
)
2767 gfc_expr
*expr1
, *expr2
;
2769 gfc_actual_arglist
*a
, *b
;
2771 gfc_expr
*matrix_a
, *matrix_b
;
2772 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2776 if (co
->op
!= EXEC_ASSIGN
)
2779 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2783 /* This has some duplication with inline_matmul_assign. This
2784 is because the creation of temporary variables could still fail,
2785 and inline_matmul_assign still needs to be able to handle these
2790 if (expr2
->expr_type
!= EXPR_FUNCTION
2791 || expr2
->value
.function
.isym
== NULL
2792 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2796 a
= expr2
->value
.function
.actual
;
2797 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2798 if (matrix_a
!= NULL
)
2800 if (matrix_a
->expr_type
== EXPR_VARIABLE
2801 && (gfc_check_dependency (matrix_a
, expr1
, true)
2802 || has_dimen_vector_ref (matrix_a
)))
2810 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2811 if (matrix_b
!= NULL
)
2813 if (matrix_b
->expr_type
== EXPR_VARIABLE
2814 && (gfc_check_dependency (matrix_b
, expr1
, true)
2815 || has_dimen_vector_ref (matrix_b
)))
2821 if (!a_tmp
&& !b_tmp
)
2825 inserted_block
= NULL
;
2826 changed_statement
= NULL
;
2830 at
= create_var (a
->expr
,"mma");
2837 bt
= create_var (b
->expr
,"mmb");
2844 /* Auxiliary function to build and simplify an array inquiry function.
2845 dim is zero-based. */
2848 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2851 gfc_expr
*dim_arg
, *kind
;
2857 case GFC_ISYM_LBOUND
:
2858 name
= "_gfortran_lbound";
2861 case GFC_ISYM_UBOUND
:
2862 name
= "_gfortran_ubound";
2866 name
= "_gfortran_size";
2873 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2874 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2875 gfc_index_integer_kind
);
2877 ec
= gfc_copy_expr (e
);
2878 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2880 gfc_simplify_expr (fcn
, 0);
2884 /* Builds a logical expression. */
2887 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2892 ts
.type
= BT_LOGICAL
;
2893 ts
.kind
= gfc_default_logical_kind
;
2894 res
= gfc_get_expr ();
2895 res
->where
= e1
->where
;
2896 res
->expr_type
= EXPR_OP
;
2897 res
->value
.op
.op
= op
;
2898 res
->value
.op
.op1
= e1
;
2899 res
->value
.op
.op2
= e2
;
2906 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2907 compatible typespecs. */
2910 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2914 res
= gfc_get_expr ();
2916 res
->where
= e1
->where
;
2917 res
->expr_type
= EXPR_OP
;
2918 res
->value
.op
.op
= op
;
2919 res
->value
.op
.op1
= e1
;
2920 res
->value
.op
.op2
= e2
;
2921 gfc_simplify_expr (res
, 0);
2925 /* Generate the IF statement for a runtime check if we want to do inlining or
2926 not - putting in the code for both branches and putting it into the syntax
2927 tree is the caller's responsibility. For fixed array sizes, this should be
2928 removed by DCE. Only called for rank-two matrices A and B. */
2931 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2933 gfc_expr
*inline_limit
;
2934 gfc_code
*if_1
, *if_2
, *else_2
;
2935 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2939 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2941 /* Calculation is done in real to avoid integer overflow. */
2943 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2945 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2947 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2950 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2951 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2952 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2956 ts
.kind
= gfc_default_real_kind
;
2957 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2958 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2959 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2961 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2962 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2964 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2965 gfc_simplify_expr (cond
, 0);
2967 else_2
= XCNEW (gfc_code
);
2968 else_2
->op
= EXEC_IF
;
2969 else_2
->loc
= a
->where
;
2971 if_2
= XCNEW (gfc_code
);
2974 if_2
->loc
= a
->where
;
2975 if_2
->block
= else_2
;
2977 if_1
= XCNEW (gfc_code
);
2980 if_1
->loc
= a
->where
;
2986 /* Insert code to issue a runtime error if the expressions are not equal. */
2989 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2992 gfc_code
*if_1
, *if_2
;
2994 gfc_actual_arglist
*a1
, *a2
, *a3
;
2996 gcc_assert (e1
->where
.lb
);
2997 /* Build the call to runtime_error. */
2998 c
= XCNEW (gfc_code
);
3002 /* Get a null-terminated message string. */
3004 a1
= gfc_get_actual_arglist ();
3005 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3006 msg
, strlen(msg
)+1);
3009 /* Pass the value of the first expression. */
3010 a2
= gfc_get_actual_arglist ();
3011 a2
->expr
= gfc_copy_expr (e1
);
3014 /* Pass the value of the second expression. */
3015 a3
= gfc_get_actual_arglist ();
3016 a3
->expr
= gfc_copy_expr (e2
);
3019 gfc_check_fe_runtime_error (c
->ext
.actual
);
3020 gfc_resolve_fe_runtime_error (c
);
3022 if_2
= XCNEW (gfc_code
);
3024 if_2
->loc
= e1
->where
;
3027 if_1
= XCNEW (gfc_code
);
3030 if_1
->loc
= e1
->where
;
3032 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3033 gfc_simplify_expr (cond
, 0);
3039 /* Handle matrix reallocation. Caller is responsible to insert into
3042 For the two-dimensional case, build
3044 if (allocated(c)) then
3045 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3047 allocate (c(size(a,1), size(b,2)))
3050 allocate (c(size(a,1),size(b,2)))
3053 and for the other cases correspondingly.
3057 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3058 enum matrix_case m_case
)
3061 gfc_expr
*allocated
, *alloc_expr
;
3062 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3063 gfc_code
*else_alloc
;
3064 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3066 gfc_expr
*cond
, *ne1
, *ne2
;
3068 if (warn_realloc_lhs
)
3069 gfc_warning (OPT_Wrealloc_lhs
,
3070 "Code for reallocating the allocatable array at %L will "
3071 "be added", &c
->where
);
3073 alloc_expr
= gfc_copy_expr (c
);
3075 ar
= gfc_find_array_ref (alloc_expr
);
3076 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3078 /* c comes in as a full ref. Change it into a copy and make it into an
3079 element ref so it has the right form for for ALLOCATE. In the same
3080 switch statement, also generate the size comparison for the secod IF
3083 ar
->type
= AR_ELEMENT
;
3088 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3089 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3090 ne1
= build_logical_expr (INTRINSIC_NE
,
3091 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3092 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3093 ne2
= build_logical_expr (INTRINSIC_NE
,
3094 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3095 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3096 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3100 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3101 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3103 ne1
= build_logical_expr (INTRINSIC_NE
,
3104 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3105 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3106 ne2
= build_logical_expr (INTRINSIC_NE
,
3107 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3108 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3109 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3114 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3115 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3117 ne1
= build_logical_expr (INTRINSIC_NE
,
3118 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3119 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3120 ne2
= build_logical_expr (INTRINSIC_NE
,
3121 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3122 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3123 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3127 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3128 cond
= build_logical_expr (INTRINSIC_NE
,
3129 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3130 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3134 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3135 cond
= build_logical_expr (INTRINSIC_NE
,
3136 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3137 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3145 gfc_simplify_expr (cond
, 0);
3147 /* We need two identical allocate statements in two
3148 branches of the IF statement. */
3150 allocate1
= XCNEW (gfc_code
);
3151 allocate1
->op
= EXEC_ALLOCATE
;
3152 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3153 allocate1
->loc
= c
->where
;
3154 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3156 allocate_else
= XCNEW (gfc_code
);
3157 allocate_else
->op
= EXEC_ALLOCATE
;
3158 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3159 allocate_else
->loc
= c
->where
;
3160 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3162 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3163 "_gfortran_allocated", c
->where
,
3164 1, gfc_copy_expr (c
));
3166 deallocate
= XCNEW (gfc_code
);
3167 deallocate
->op
= EXEC_DEALLOCATE
;
3168 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3169 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3170 deallocate
->next
= allocate1
;
3171 deallocate
->loc
= c
->where
;
3173 if_size_2
= XCNEW (gfc_code
);
3174 if_size_2
->op
= EXEC_IF
;
3175 if_size_2
->expr1
= cond
;
3176 if_size_2
->loc
= c
->where
;
3177 if_size_2
->next
= deallocate
;
3179 if_size_1
= XCNEW (gfc_code
);
3180 if_size_1
->op
= EXEC_IF
;
3181 if_size_1
->block
= if_size_2
;
3182 if_size_1
->loc
= c
->where
;
3184 else_alloc
= XCNEW (gfc_code
);
3185 else_alloc
->op
= EXEC_IF
;
3186 else_alloc
->loc
= c
->where
;
3187 else_alloc
->next
= allocate_else
;
3189 if_alloc_2
= XCNEW (gfc_code
);
3190 if_alloc_2
->op
= EXEC_IF
;
3191 if_alloc_2
->expr1
= allocated
;
3192 if_alloc_2
->loc
= c
->where
;
3193 if_alloc_2
->next
= if_size_1
;
3194 if_alloc_2
->block
= else_alloc
;
3196 if_alloc_1
= XCNEW (gfc_code
);
3197 if_alloc_1
->op
= EXEC_IF
;
3198 if_alloc_1
->block
= if_alloc_2
;
3199 if_alloc_1
->loc
= c
->where
;
3204 /* Callback function for has_function_or_op. */
3207 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3208 void *data ATTRIBUTE_UNUSED
)
3213 return (*e
)->expr_type
== EXPR_FUNCTION
3214 || (*e
)->expr_type
== EXPR_OP
;
3217 /* Returns true if the expression contains a function. */
3220 has_function_or_op (gfc_expr
**e
)
3225 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3228 /* Freeze (assign to a temporary variable) a single expression. */
3231 freeze_expr (gfc_expr
**ep
)
3234 if (has_function_or_op (ep
))
3236 ne
= create_var (*ep
, "freeze");
3241 /* Go through an expression's references and assign them to temporary
3242 variables if they contain functions. This is usually done prior to
3243 front-end scalarization to avoid multiple invocations of functions. */
3246 freeze_references (gfc_expr
*e
)
3252 for (r
=e
->ref
; r
; r
=r
->next
)
3254 if (r
->type
== REF_SUBSTRING
)
3256 if (r
->u
.ss
.start
!= NULL
)
3257 freeze_expr (&r
->u
.ss
.start
);
3259 if (r
->u
.ss
.end
!= NULL
)
3260 freeze_expr (&r
->u
.ss
.end
);
3262 else if (r
->type
== REF_ARRAY
)
3271 for (i
=0; i
<ar
->dimen
; i
++)
3273 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3275 freeze_expr (&ar
->start
[i
]);
3276 freeze_expr (&ar
->end
[i
]);
3277 freeze_expr (&ar
->stride
[i
]);
3279 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3281 freeze_expr (&ar
->start
[i
]);
3287 for (i
=0; i
<ar
->dimen
; i
++)
3288 freeze_expr (&ar
->start
[i
]);
3298 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3301 convert_to_index_kind (gfc_expr
*e
)
3305 gcc_assert (e
!= NULL
);
3307 res
= gfc_copy_expr (e
);
3309 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3311 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3315 ts
.type
= BT_INTEGER
;
3316 ts
.kind
= gfc_index_integer_kind
;
3318 gfc_convert_type_warn (e
, &ts
, 2, 0);
3324 /* Function to create a DO loop including creation of the
3325 iteration variable. gfc_expr are copied.*/
3328 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3329 gfc_namespace
*ns
, char *vname
)
3332 char name
[GFC_MAX_SYMBOL_LEN
+1];
3333 gfc_symtree
*symtree
;
3338 /* Create an expression for the iteration variable. */
3340 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3342 sprintf (name
, "__var_%d_do", var_num
++);
3345 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3348 /* Create the loop variable. */
3350 symbol
= symtree
->n
.sym
;
3351 symbol
->ts
.type
= BT_INTEGER
;
3352 symbol
->ts
.kind
= gfc_index_integer_kind
;
3353 symbol
->attr
.flavor
= FL_VARIABLE
;
3354 symbol
->attr
.referenced
= 1;
3355 symbol
->attr
.dimension
= 0;
3356 symbol
->attr
.fe_temp
= 1;
3357 gfc_commit_symbol (symbol
);
3359 i
= gfc_get_expr ();
3360 i
->expr_type
= EXPR_VARIABLE
;
3364 i
->symtree
= symtree
;
3366 /* ... and the nested DO statements. */
3367 n
= XCNEW (gfc_code
);
3370 n
->ext
.iterator
= gfc_get_iterator ();
3371 n
->ext
.iterator
->var
= i
;
3372 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3373 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3375 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3377 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3380 n2
= XCNEW (gfc_code
);
3388 /* Get the upper bound of the DO loops for matmul along a dimension. This
3392 get_size_m1 (gfc_expr
*e
, int dimen
)
3397 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3399 res
= gfc_get_constant_expr (BT_INTEGER
,
3400 gfc_index_integer_kind
, &e
->where
);
3401 mpz_sub_ui (res
->value
.integer
, size
, 1);
3406 res
= get_operand (INTRINSIC_MINUS
,
3407 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3408 gfc_get_int_expr (gfc_index_integer_kind
,
3410 gfc_simplify_expr (res
, 0);
3416 /* Function to return a scalarized expression. It is assumed that indices are
3417 zero based to make generation of DO loops easier. A zero as index will
3418 access the first element along a dimension. Single element references will
3419 be skipped. A NULL as an expression will be replaced by a full reference.
3420 This assumes that the index loops have gfc_index_integer_kind, and that all
3421 references have been frozen. */
3424 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3433 e
= gfc_copy_expr(e_in
);
3437 ar
= gfc_find_array_ref (e
);
3439 /* We scalarize count_index variables, reducing the rank by count_index. */
3441 e
->rank
= rank
- count_index
;
3443 was_fullref
= ar
->type
== AR_FULL
;
3446 ar
->type
= AR_ELEMENT
;
3448 ar
->type
= AR_SECTION
;
3450 /* Loop over the indices. For each index, create the expression
3451 index * stride + lbound(e, dim). */
3454 for (i
=0; i
< ar
->dimen
; i
++)
3456 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3458 if (index
[i_index
] != NULL
)
3460 gfc_expr
*lbound
, *nindex
;
3463 loopvar
= gfc_copy_expr (index
[i_index
]);
3469 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3470 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3474 ts
.type
= BT_INTEGER
;
3475 ts
.kind
= gfc_index_integer_kind
;
3476 gfc_convert_type (tmp
, &ts
, 2);
3478 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3483 /* Calculate the lower bound of the expression. */
3486 lbound
= gfc_copy_expr (ar
->start
[i
]);
3487 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3491 ts
.type
= BT_INTEGER
;
3492 ts
.kind
= gfc_index_integer_kind
;
3493 gfc_convert_type (lbound
, &ts
, 2);
3502 lbound_e
= gfc_copy_expr (e_in
);
3504 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3505 if (ref
->type
== REF_ARRAY
3506 && (ref
->u
.ar
.type
== AR_FULL
3507 || ref
->u
.ar
.type
== AR_SECTION
))
3512 gfc_free_ref_list (ref
->next
);
3518 /* Look at full individual sections, like a(:). The first index
3519 is the lbound of a full ref. */
3525 for (j
= 0; j
< ar
->dimen
; j
++)
3527 gfc_free_expr (ar
->start
[j
]);
3528 ar
->start
[j
] = NULL
;
3529 gfc_free_expr (ar
->end
[j
]);
3531 gfc_free_expr (ar
->stride
[j
]);
3532 ar
->stride
[j
] = NULL
;
3535 /* We have to get rid of the shape, if there is one. Do
3536 so by freeing it and calling gfc_resolve to rebuild
3537 it, if necessary. */
3539 if (lbound_e
->shape
)
3540 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3542 lbound_e
->rank
= ar
->dimen
;
3543 gfc_resolve_expr (lbound_e
);
3545 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3547 gfc_free_expr (lbound_e
);
3550 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3552 gfc_free_expr (ar
->start
[i
]);
3553 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3555 gfc_free_expr (ar
->end
[i
]);
3557 gfc_free_expr (ar
->stride
[i
]);
3558 ar
->stride
[i
] = NULL
;
3559 gfc_simplify_expr (ar
->start
[i
], 0);
3561 else if (was_fullref
)
3563 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3572 /* Helper function to check for a dimen vector as subscript. */
3575 has_dimen_vector_ref (gfc_expr
*e
)
3580 ar
= gfc_find_array_ref (e
);
3582 if (ar
->type
== AR_FULL
)
3585 for (i
=0; i
<ar
->dimen
; i
++)
3586 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3592 /* If handed an expression of the form
3596 check if A can be handled by matmul and return if there is an uneven number
3597 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3598 otherwise. The caller has to check for the correct rank. */
3601 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3608 if (e
->expr_type
== EXPR_VARIABLE
)
3610 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3613 else if (e
->expr_type
== EXPR_FUNCTION
)
3615 if (e
->value
.function
.isym
== NULL
)
3618 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3620 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3621 *transpose
= !*transpose
;
3627 e
= e
->value
.function
.actual
->expr
;
3634 /* Inline assignments of the form c = matmul(a,b).
3635 Handle only the cases currently where b and c are rank-two arrays.
3637 This basically translates the code to
3643 do k=0, size(a, 2)-1
3644 do i=0, size(a, 1)-1
3645 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3646 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3647 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3648 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3657 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3658 void *data ATTRIBUTE_UNUSED
)
3661 gfc_expr
*expr1
, *expr2
;
3662 gfc_expr
*matrix_a
, *matrix_b
;
3663 gfc_actual_arglist
*a
, *b
;
3664 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3666 gfc_expr
*u1
, *u2
, *u3
;
3668 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3670 gfc_expr
*var_1
, *var_2
, *var_3
;
3673 gfc_intrinsic_op op_times
, op_plus
;
3674 enum matrix_case m_case
;
3676 gfc_code
*if_limit
= NULL
;
3677 gfc_code
**next_code_point
;
3678 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3680 if (co
->op
!= EXEC_ASSIGN
)
3686 /* The BLOCKS generated for the temporary variables and FORALL don't
3688 if (forall_level
> 0)
3691 /* For now don't do anything in OpenMP workshare, it confuses
3692 its translation, which expects only the allowed statements in there.
3693 We should figure out how to parallelize this eventually. */
3694 if (in_omp_workshare
)
3699 if (expr2
->expr_type
!= EXPR_FUNCTION
3700 || expr2
->value
.function
.isym
== NULL
3701 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3705 inserted_block
= NULL
;
3706 changed_statement
= NULL
;
3708 a
= expr2
->value
.function
.actual
;
3709 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3710 if (matrix_a
== NULL
)
3714 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3715 if (matrix_b
== NULL
)
3718 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3719 || has_dimen_vector_ref (matrix_b
))
3722 /* We do not handle data dependencies yet. */
3723 if (gfc_check_dependency (expr1
, matrix_a
, true)
3724 || gfc_check_dependency (expr1
, matrix_b
, true))
3728 if (matrix_a
->rank
== 2)
3732 if (matrix_b
->rank
== 2 && !transpose_b
)
3737 if (matrix_b
->rank
== 1)
3739 else /* matrix_b->rank == 2 */
3748 else /* matrix_a->rank == 1 */
3750 if (matrix_b
->rank
== 2)
3760 ns
= insert_block ();
3762 /* Assign the type of the zero expression for initializing the resulting
3763 array, and the expression (+ and * for real, integer and complex;
3764 .and. and .or for logical. */
3766 switch(expr1
->ts
.type
)
3769 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3770 op_times
= INTRINSIC_TIMES
;
3771 op_plus
= INTRINSIC_PLUS
;
3775 op_times
= INTRINSIC_AND
;
3776 op_plus
= INTRINSIC_OR
;
3777 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3781 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3783 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3784 op_times
= INTRINSIC_TIMES
;
3785 op_plus
= INTRINSIC_PLUS
;
3789 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3791 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3792 op_times
= INTRINSIC_TIMES
;
3793 op_plus
= INTRINSIC_PLUS
;
3801 current_code
= &ns
->code
;
3803 /* Freeze the references, keeping track of how many temporary variables were
3806 freeze_references (matrix_a
);
3807 freeze_references (matrix_b
);
3808 freeze_references (expr1
);
3811 next_code_point
= current_code
;
3814 next_code_point
= &ns
->code
;
3815 for (i
=0; i
<n_vars
; i
++)
3816 next_code_point
= &(*next_code_point
)->next
;
3819 /* Take care of the inline flag. If the limit check evaluates to a
3820 constant, dead code elimination will eliminate the unneeded branch. */
3822 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3824 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3826 /* Insert the original statement into the else branch. */
3827 if_limit
->block
->block
->next
= co
;
3830 /* ... and the new ones go into the original one. */
3831 *next_code_point
= if_limit
;
3832 next_code_point
= &if_limit
->block
->next
;
3835 assign_zero
= XCNEW (gfc_code
);
3836 assign_zero
->op
= EXEC_ASSIGN
;
3837 assign_zero
->loc
= co
->loc
;
3838 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3839 assign_zero
->expr2
= zero_e
;
3841 /* Handle the reallocation, if needed. */
3842 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3844 gfc_code
*lhs_alloc
;
3846 /* Only need to check a single dimension for the A2B2 case for
3847 bounds checking, the rest will be allocated. Also check this
3850 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3855 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3856 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3857 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3858 "in MATMUL intrinsic: Is %ld, should be %ld");
3859 *next_code_point
= test
;
3860 next_code_point
= &test
->next
;
3864 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3866 *next_code_point
= lhs_alloc
;
3867 next_code_point
= &lhs_alloc
->next
;
3870 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3873 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3875 if (m_case
== A2B2
|| m_case
== A2B1
)
3877 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3878 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3879 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3880 "in MATMUL intrinsic: Is %ld, should be %ld");
3881 *next_code_point
= test
;
3882 next_code_point
= &test
->next
;
3884 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3885 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3888 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3889 "MATMUL intrinsic for dimension 1: "
3890 "is %ld, should be %ld");
3891 else if (m_case
== A2B1
)
3892 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3893 "MATMUL intrinsic: "
3894 "is %ld, should be %ld");
3897 *next_code_point
= test
;
3898 next_code_point
= &test
->next
;
3900 else if (m_case
== A1B2
)
3902 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3903 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3904 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3905 "in MATMUL intrinsic: Is %ld, should be %ld");
3906 *next_code_point
= test
;
3907 next_code_point
= &test
->next
;
3909 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3910 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3912 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3913 "MATMUL intrinsic: "
3914 "is %ld, should be %ld");
3916 *next_code_point
= test
;
3917 next_code_point
= &test
->next
;
3922 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3923 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3924 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3925 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3927 *next_code_point
= test
;
3928 next_code_point
= &test
->next
;
3931 if (m_case
== A2B2T
)
3933 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3934 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3935 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3936 "MATMUL intrinsic for dimension 1: "
3937 "is %ld, should be %ld");
3939 *next_code_point
= test
;
3940 next_code_point
= &test
->next
;
3942 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3943 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3944 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3945 "MATMUL intrinsic for dimension 2: "
3946 "is %ld, should be %ld");
3947 *next_code_point
= test
;
3948 next_code_point
= &test
->next
;
3950 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3951 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3953 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3954 "MATMUL intrnisic for dimension 2: "
3955 "is %ld, should be %ld");
3956 *next_code_point
= test
;
3957 next_code_point
= &test
->next
;
3961 if (m_case
== A2TB2
)
3963 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3964 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3966 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
3967 "MATMUL intrinsic for dimension 1: "
3968 "is %ld, should be %ld");
3970 *next_code_point
= test
;
3971 next_code_point
= &test
->next
;
3973 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3974 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3975 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3976 "MATMUL intrinsic for dimension 2: "
3977 "is %ld, should be %ld");
3978 *next_code_point
= test
;
3979 next_code_point
= &test
->next
;
3981 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3982 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3984 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
3985 "MATMUL intrnisic for dimension 2: "
3986 "is %ld, should be %ld");
3987 *next_code_point
= test
;
3988 next_code_point
= &test
->next
;
3993 *next_code_point
= assign_zero
;
3995 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3997 assign_matmul
= XCNEW (gfc_code
);
3998 assign_matmul
->op
= EXEC_ASSIGN
;
3999 assign_matmul
->loc
= co
->loc
;
4001 /* Get the bounds for the loops, create them and create the scalarized
4007 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4009 u1
= get_size_m1 (matrix_b
, 2);
4010 u2
= get_size_m1 (matrix_a
, 2);
4011 u3
= get_size_m1 (matrix_a
, 1);
4013 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4014 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4015 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4017 do_1
->block
->next
= do_2
;
4018 do_2
->block
->next
= do_3
;
4019 do_3
->block
->next
= assign_matmul
;
4021 var_1
= do_1
->ext
.iterator
->var
;
4022 var_2
= do_2
->ext
.iterator
->var
;
4023 var_3
= do_3
->ext
.iterator
->var
;
4027 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4031 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4035 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4040 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4042 u1
= get_size_m1 (matrix_b
, 1);
4043 u2
= get_size_m1 (matrix_a
, 2);
4044 u3
= get_size_m1 (matrix_a
, 1);
4046 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4047 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4048 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4050 do_1
->block
->next
= do_2
;
4051 do_2
->block
->next
= do_3
;
4052 do_3
->block
->next
= assign_matmul
;
4054 var_1
= do_1
->ext
.iterator
->var
;
4055 var_2
= do_2
->ext
.iterator
->var
;
4056 var_3
= do_3
->ext
.iterator
->var
;
4060 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4064 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4068 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4073 inline_limit_check (matrix_a
, matrix_b
, m_case
);
4075 u1
= get_size_m1 (matrix_a
, 2);
4076 u2
= get_size_m1 (matrix_b
, 2);
4077 u3
= get_size_m1 (matrix_a
, 1);
4079 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4080 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4081 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4083 do_1
->block
->next
= do_2
;
4084 do_2
->block
->next
= do_3
;
4085 do_3
->block
->next
= assign_matmul
;
4087 var_1
= do_1
->ext
.iterator
->var
;
4088 var_2
= do_2
->ext
.iterator
->var
;
4089 var_3
= do_3
->ext
.iterator
->var
;
4093 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4097 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4101 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4106 u1
= get_size_m1 (matrix_b
, 1);
4107 u2
= get_size_m1 (matrix_a
, 1);
4109 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4110 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4112 do_1
->block
->next
= do_2
;
4113 do_2
->block
->next
= assign_matmul
;
4115 var_1
= do_1
->ext
.iterator
->var
;
4116 var_2
= do_2
->ext
.iterator
->var
;
4119 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4123 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4126 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4131 u1
= get_size_m1 (matrix_b
, 2);
4132 u2
= get_size_m1 (matrix_a
, 1);
4134 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4135 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4137 do_1
->block
->next
= do_2
;
4138 do_2
->block
->next
= assign_matmul
;
4140 var_1
= do_1
->ext
.iterator
->var
;
4141 var_2
= do_2
->ext
.iterator
->var
;
4144 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4147 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4151 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4159 /* Build the conjg call around the variables. Set the typespec manually
4160 because gfc_build_intrinsic_call sometimes gets this wrong. */
4165 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4166 matrix_a
->where
, 1, ascalar
);
4174 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4175 matrix_b
->where
, 1, bscalar
);
4178 /* First loop comes after the zero assignment. */
4179 assign_zero
->next
= do_1
;
4181 /* Build the assignment expression in the loop. */
4182 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4184 mult
= get_operand (op_times
, ascalar
, bscalar
);
4185 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4187 /* If we don't want to keep the original statement around in
4188 the else branch, we can free it. */
4190 if (if_limit
== NULL
)
4191 gfc_free_statements(co
);
4195 gfc_free_expr (zero
);
4200 #define WALK_SUBEXPR(NODE) \
4203 result = gfc_expr_walker (&(NODE), exprfn, data); \
4208 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4210 /* Walk expression *E, calling EXPRFN on each expression in it. */
4213 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4217 int walk_subtrees
= 1;
4218 gfc_actual_arglist
*a
;
4222 int result
= exprfn (e
, &walk_subtrees
, data
);
4226 switch ((*e
)->expr_type
)
4229 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4230 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4233 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4234 WALK_SUBEXPR (a
->expr
);
4238 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4239 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4240 WALK_SUBEXPR (a
->expr
);
4243 case EXPR_STRUCTURE
:
4245 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4246 c
= gfc_constructor_next (c
))
4248 if (c
->iterator
== NULL
)
4249 WALK_SUBEXPR (c
->expr
);
4253 WALK_SUBEXPR (c
->expr
);
4255 WALK_SUBEXPR (c
->iterator
->var
);
4256 WALK_SUBEXPR (c
->iterator
->start
);
4257 WALK_SUBEXPR (c
->iterator
->end
);
4258 WALK_SUBEXPR (c
->iterator
->step
);
4262 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4265 /* Fall through to the variable case in order to walk the
4269 case EXPR_SUBSTRING
:
4271 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4280 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4282 for (i
=0; i
< ar
->dimen
; i
++)
4284 WALK_SUBEXPR (ar
->start
[i
]);
4285 WALK_SUBEXPR (ar
->end
[i
]);
4286 WALK_SUBEXPR (ar
->stride
[i
]);
4293 WALK_SUBEXPR (r
->u
.ss
.start
);
4294 WALK_SUBEXPR (r
->u
.ss
.end
);
4310 #define WALK_SUBCODE(NODE) \
4313 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
4319 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
4320 on each expression in it. If any of the hooks returns non-zero, that
4321 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
4322 no subcodes or subexpressions are traversed. */
4325 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
4328 for (; *c
; c
= &(*c
)->next
)
4330 int walk_subtrees
= 1;
4331 int result
= codefn (c
, &walk_subtrees
, data
);
4338 gfc_actual_arglist
*a
;
4340 gfc_association_list
*alist
;
4341 bool saved_in_omp_workshare
;
4342 bool saved_in_where
;
4344 /* There might be statement insertions before the current code,
4345 which must not affect the expression walker. */
4348 saved_in_omp_workshare
= in_omp_workshare
;
4349 saved_in_where
= in_where
;
4355 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
4356 if (co
->ext
.block
.assoc
)
4358 bool saved_in_assoc_list
= in_assoc_list
;
4360 in_assoc_list
= true;
4361 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
4362 WALK_SUBEXPR (alist
->target
);
4364 in_assoc_list
= saved_in_assoc_list
;
4371 WALK_SUBEXPR (co
->ext
.iterator
->var
);
4372 WALK_SUBEXPR (co
->ext
.iterator
->start
);
4373 WALK_SUBEXPR (co
->ext
.iterator
->end
);
4374 WALK_SUBEXPR (co
->ext
.iterator
->step
);
4386 case EXEC_ASSIGN_CALL
:
4387 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4388 WALK_SUBEXPR (a
->expr
);
4392 WALK_SUBEXPR (co
->expr1
);
4393 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
4394 WALK_SUBEXPR (a
->expr
);
4398 WALK_SUBEXPR (co
->expr1
);
4400 for (b
= co
->block
; b
; b
= b
->block
)
4403 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
4405 WALK_SUBEXPR (cp
->low
);
4406 WALK_SUBEXPR (cp
->high
);
4408 WALK_SUBCODE (b
->next
);
4413 case EXEC_DEALLOCATE
:
4416 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
4417 WALK_SUBEXPR (a
->expr
);
4422 case EXEC_DO_CONCURRENT
:
4424 gfc_forall_iterator
*fa
;
4425 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4427 WALK_SUBEXPR (fa
->var
);
4428 WALK_SUBEXPR (fa
->start
);
4429 WALK_SUBEXPR (fa
->end
);
4430 WALK_SUBEXPR (fa
->stride
);
4432 if (co
->op
== EXEC_FORALL
)
4438 WALK_SUBEXPR (co
->ext
.open
->unit
);
4439 WALK_SUBEXPR (co
->ext
.open
->file
);
4440 WALK_SUBEXPR (co
->ext
.open
->status
);
4441 WALK_SUBEXPR (co
->ext
.open
->access
);
4442 WALK_SUBEXPR (co
->ext
.open
->form
);
4443 WALK_SUBEXPR (co
->ext
.open
->recl
);
4444 WALK_SUBEXPR (co
->ext
.open
->blank
);
4445 WALK_SUBEXPR (co
->ext
.open
->position
);
4446 WALK_SUBEXPR (co
->ext
.open
->action
);
4447 WALK_SUBEXPR (co
->ext
.open
->delim
);
4448 WALK_SUBEXPR (co
->ext
.open
->pad
);
4449 WALK_SUBEXPR (co
->ext
.open
->iostat
);
4450 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
4451 WALK_SUBEXPR (co
->ext
.open
->convert
);
4452 WALK_SUBEXPR (co
->ext
.open
->decimal
);
4453 WALK_SUBEXPR (co
->ext
.open
->encoding
);
4454 WALK_SUBEXPR (co
->ext
.open
->round
);
4455 WALK_SUBEXPR (co
->ext
.open
->sign
);
4456 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
4457 WALK_SUBEXPR (co
->ext
.open
->id
);
4458 WALK_SUBEXPR (co
->ext
.open
->newunit
);
4459 WALK_SUBEXPR (co
->ext
.open
->share
);
4460 WALK_SUBEXPR (co
->ext
.open
->cc
);
4464 WALK_SUBEXPR (co
->ext
.close
->unit
);
4465 WALK_SUBEXPR (co
->ext
.close
->status
);
4466 WALK_SUBEXPR (co
->ext
.close
->iostat
);
4467 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
4470 case EXEC_BACKSPACE
:
4474 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
4475 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
4476 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
4480 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
4481 WALK_SUBEXPR (co
->ext
.inquire
->file
);
4482 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
4483 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
4484 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
4485 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
4486 WALK_SUBEXPR (co
->ext
.inquire
->number
);
4487 WALK_SUBEXPR (co
->ext
.inquire
->named
);
4488 WALK_SUBEXPR (co
->ext
.inquire
->name
);
4489 WALK_SUBEXPR (co
->ext
.inquire
->access
);
4490 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
4491 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
4492 WALK_SUBEXPR (co
->ext
.inquire
->form
);
4493 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
4494 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
4495 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
4496 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
4497 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
4498 WALK_SUBEXPR (co
->ext
.inquire
->position
);
4499 WALK_SUBEXPR (co
->ext
.inquire
->action
);
4500 WALK_SUBEXPR (co
->ext
.inquire
->read
);
4501 WALK_SUBEXPR (co
->ext
.inquire
->write
);
4502 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
4503 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
4504 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
4505 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
4506 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
4507 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
4508 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
4509 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
4510 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
4511 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
4512 WALK_SUBEXPR (co
->ext
.inquire
->id
);
4513 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
4514 WALK_SUBEXPR (co
->ext
.inquire
->size
);
4515 WALK_SUBEXPR (co
->ext
.inquire
->round
);
4519 WALK_SUBEXPR (co
->ext
.wait
->unit
);
4520 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
4521 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
4522 WALK_SUBEXPR (co
->ext
.wait
->id
);
4527 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
4528 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
4529 WALK_SUBEXPR (co
->ext
.dt
->rec
);
4530 WALK_SUBEXPR (co
->ext
.dt
->advance
);
4531 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
4532 WALK_SUBEXPR (co
->ext
.dt
->size
);
4533 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
4534 WALK_SUBEXPR (co
->ext
.dt
->id
);
4535 WALK_SUBEXPR (co
->ext
.dt
->pos
);
4536 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
4537 WALK_SUBEXPR (co
->ext
.dt
->blank
);
4538 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
4539 WALK_SUBEXPR (co
->ext
.dt
->delim
);
4540 WALK_SUBEXPR (co
->ext
.dt
->pad
);
4541 WALK_SUBEXPR (co
->ext
.dt
->round
);
4542 WALK_SUBEXPR (co
->ext
.dt
->sign
);
4543 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
4546 case EXEC_OMP_PARALLEL
:
4547 case EXEC_OMP_PARALLEL_DO
:
4548 case EXEC_OMP_PARALLEL_DO_SIMD
:
4549 case EXEC_OMP_PARALLEL_SECTIONS
:
4551 in_omp_workshare
= false;
4553 /* This goto serves as a shortcut to avoid code
4554 duplication or a larger if or switch statement. */
4555 goto check_omp_clauses
;
4557 case EXEC_OMP_WORKSHARE
:
4558 case EXEC_OMP_PARALLEL_WORKSHARE
:
4560 in_omp_workshare
= true;
4564 case EXEC_OMP_CRITICAL
:
4565 case EXEC_OMP_DISTRIBUTE
:
4566 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
4567 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4568 case EXEC_OMP_DISTRIBUTE_SIMD
:
4570 case EXEC_OMP_DO_SIMD
:
4571 case EXEC_OMP_ORDERED
:
4572 case EXEC_OMP_SECTIONS
:
4573 case EXEC_OMP_SINGLE
:
4574 case EXEC_OMP_END_SINGLE
:
4576 case EXEC_OMP_TASKLOOP
:
4577 case EXEC_OMP_TASKLOOP_SIMD
:
4578 case EXEC_OMP_TARGET
:
4579 case EXEC_OMP_TARGET_DATA
:
4580 case EXEC_OMP_TARGET_ENTER_DATA
:
4581 case EXEC_OMP_TARGET_EXIT_DATA
:
4582 case EXEC_OMP_TARGET_PARALLEL
:
4583 case EXEC_OMP_TARGET_PARALLEL_DO
:
4584 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
4585 case EXEC_OMP_TARGET_SIMD
:
4586 case EXEC_OMP_TARGET_TEAMS
:
4587 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
4588 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4589 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4590 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4591 case EXEC_OMP_TARGET_UPDATE
:
4593 case EXEC_OMP_TEAMS
:
4594 case EXEC_OMP_TEAMS_DISTRIBUTE
:
4595 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4596 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4597 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
4599 /* Come to this label only from the
4600 EXEC_OMP_PARALLEL_* cases above. */
4604 if (co
->ext
.omp_clauses
)
4606 gfc_omp_namelist
*n
;
4607 static int list_types
[]
4608 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4609 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4611 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4612 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4613 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4614 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4615 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4616 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4617 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4618 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4619 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4620 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4621 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4622 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4623 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4624 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4625 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4626 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4628 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4630 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4632 WALK_SUBEXPR (n
->expr
);
4639 WALK_SUBEXPR (co
->expr1
);
4640 WALK_SUBEXPR (co
->expr2
);
4641 WALK_SUBEXPR (co
->expr3
);
4642 WALK_SUBEXPR (co
->expr4
);
4643 for (b
= co
->block
; b
; b
= b
->block
)
4645 WALK_SUBEXPR (b
->expr1
);
4646 WALK_SUBEXPR (b
->expr2
);
4647 WALK_SUBCODE (b
->next
);
4650 if (co
->op
== EXEC_FORALL
)
4653 if (co
->op
== EXEC_DO
)
4656 if (co
->op
== EXEC_IF
)
4659 if (co
->op
== EXEC_SELECT
)
4662 in_omp_workshare
= saved_in_omp_workshare
;
4663 in_where
= saved_in_where
;