1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2016 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 void optimize_reduction (gfc_namespace
*);
43 static int callback_reduction (gfc_expr
**, int *, void *);
44 static void realloc_strings (gfc_namespace
*);
45 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
46 static int inline_matmul_assign (gfc_code
**, int *, void *);
47 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
48 locus
*, gfc_namespace
*,
51 /* How deep we are inside an argument list. */
53 static int count_arglist
;
55 /* Vector of gfc_expr ** we operate on. */
57 static vec
<gfc_expr
**> expr_array
;
59 /* Pointer to the gfc_code we currently work on - to be able to insert
60 a block before the statement. */
62 static gfc_code
**current_code
;
64 /* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
67 static gfc_code
*inserted_block
, **changed_statement
;
69 /* The namespace we are currently dealing with. */
71 static gfc_namespace
*current_ns
;
73 /* If we are within any forall loop. */
75 static int forall_level
;
77 /* Keep track of whether we are within an OMP workshare. */
79 static bool in_omp_workshare
;
81 /* Keep track of whether we are within a WHERE statement. */
85 /* Keep track of iterators for array constructors. */
87 static int iterator_level
;
89 /* Keep track of DO loop levels. */
91 static vec
<gfc_code
*> doloop_list
;
93 static int doloop_level
;
95 /* Vector of gfc_expr * to keep track of DO loops. */
97 struct my_struct
*evec
;
99 /* Keep track of association lists. */
101 static bool in_assoc_list
;
103 /* Counter for temporary variables. */
105 static int var_num
= 1;
107 /* What sort of matrix we are dealing with when inlining MATMUL. */
109 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
};
111 /* Keep track of the number of expressions we have inserted so far
116 /* Entry point - run all passes for a namespace. */
119 gfc_run_passes (gfc_namespace
*ns
)
122 /* Warn about dubious DO loops where the index might
127 doloop_list
.release ();
129 if (flag_frontend_optimize
)
131 optimize_namespace (ns
);
132 optimize_reduction (ns
);
133 if (flag_dump_fortran_optimized
)
134 gfc_dump_parse_tree (ns
, stdout
);
136 expr_array
.release ();
139 if (flag_realloc_lhs
)
140 realloc_strings (ns
);
143 /* Callback for each gfc_code node invoked from check_realloc_strings.
144 For an allocatable LHS string which also appears as a variable on
156 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
157 void *data ATTRIBUTE_UNUSED
)
159 gfc_expr
*expr1
, *expr2
;
163 if (co
->op
!= EXEC_ASSIGN
)
167 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
168 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
171 expr2
= gfc_discard_nops (co
->expr2
);
172 if (expr2
->expr_type
!= EXPR_VARIABLE
)
175 if (!gfc_check_dependency (expr1
, expr2
, true))
178 /* gfc_check_dependency doesn't always pick up identical expressions.
179 However, eliminating the above sends the compiler into an infinite
180 loop on valid expressions. Without this check, the gimplifier emits
181 an ICE for a = a, where a is deferred character length. */
182 if (!gfc_dep_compare_expr (expr1
, expr2
))
186 inserted_block
= NULL
;
187 changed_statement
= NULL
;
188 n
= create_var (expr2
, "trim");
193 /* Callback for each gfc_code node invoked through gfc_code_walker
194 from optimize_namespace. */
197 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
198 void *data ATTRIBUTE_UNUSED
)
205 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
206 || op
== EXEC_CALL_PPC
)
212 inserted_block
= NULL
;
213 changed_statement
= NULL
;
215 if (op
== EXEC_ASSIGN
)
216 optimize_assignment (*c
);
220 /* Callback for each gfc_expr node invoked through gfc_code_walker
221 from optimize_namespace. */
224 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
225 void *data ATTRIBUTE_UNUSED
)
229 if ((*e
)->expr_type
== EXPR_FUNCTION
)
232 function_expr
= true;
235 function_expr
= false;
237 if (optimize_trim (*e
))
238 gfc_simplify_expr (*e
, 0);
240 if (optimize_lexical_comparison (*e
))
241 gfc_simplify_expr (*e
, 0);
243 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
244 gfc_simplify_expr (*e
, 0);
246 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
247 switch ((*e
)->value
.function
.isym
->id
)
249 case GFC_ISYM_MINLOC
:
250 case GFC_ISYM_MAXLOC
:
251 optimize_minmaxloc (e
);
263 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
264 function is a scalar, just copy it; otherwise returns the new element, the
265 old one can be freed. */
268 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
270 gfc_expr
*fcn
, *e
= c
->expr
;
272 fcn
= gfc_copy_expr (e
);
275 gfc_constructor_base newbase
;
277 gfc_constructor
*new_c
;
280 new_expr
= gfc_get_expr ();
281 new_expr
->expr_type
= EXPR_ARRAY
;
282 new_expr
->ts
= e
->ts
;
283 new_expr
->where
= e
->where
;
285 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
286 new_c
->iterator
= c
->iterator
;
287 new_expr
->value
.constructor
= newbase
;
295 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
297 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
298 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
299 fn
->value
.function
.isym
->name
,
300 fn
->where
, 3, fcn
, NULL
, NULL
);
301 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
302 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
303 fn
->value
.function
.isym
->name
,
304 fn
->where
, 2, fcn
, NULL
);
306 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
308 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
314 /* Callback function for optimzation of reductions to scalars. Transform ANY
315 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
316 correspondingly. Handly only the simple cases without MASK and DIM. */
319 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
320 void *data ATTRIBUTE_UNUSED
)
325 gfc_actual_arglist
*a
;
326 gfc_actual_arglist
*dim
;
328 gfc_expr
*res
, *new_expr
;
329 gfc_actual_arglist
*mask
;
333 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
334 || fn
->value
.function
.isym
== NULL
)
337 id
= fn
->value
.function
.isym
->id
;
339 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
340 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
343 a
= fn
->value
.function
.actual
;
345 /* Don't handle MASK or DIM. */
349 if (dim
->expr
!= NULL
)
352 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
355 if ( mask
->expr
!= NULL
)
361 if (arg
->expr_type
!= EXPR_ARRAY
)
370 case GFC_ISYM_PRODUCT
:
371 op
= INTRINSIC_TIMES
;
386 c
= gfc_constructor_first (arg
->value
.constructor
);
388 /* Don't do any simplififcation if we have
389 - no element in the constructor or
390 - only have a single element in the array which contains an
396 res
= copy_walk_reduction_arg (c
, fn
);
398 c
= gfc_constructor_next (c
);
401 new_expr
= gfc_get_expr ();
402 new_expr
->ts
= fn
->ts
;
403 new_expr
->expr_type
= EXPR_OP
;
404 new_expr
->rank
= fn
->rank
;
405 new_expr
->where
= fn
->where
;
406 new_expr
->value
.op
.op
= op
;
407 new_expr
->value
.op
.op1
= res
;
408 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
410 c
= gfc_constructor_next (c
);
413 gfc_simplify_expr (res
, 0);
420 /* Callback function for common function elimination, called from cfe_expr_0.
421 Put all eligible function expressions into expr_array. */
424 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
425 void *data ATTRIBUTE_UNUSED
)
428 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
431 /* We don't do character functions with unknown charlens. */
432 if ((*e
)->ts
.type
== BT_CHARACTER
433 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
434 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
437 /* We don't do function elimination within FORALL statements, it can
438 lead to wrong-code in certain circumstances. */
440 if (forall_level
> 0)
443 /* Function elimination inside an iterator could lead to functions which
444 depend on iterator variables being moved outside. FIXME: We should check
445 if the functions do indeed depend on the iterator variable. */
447 if (iterator_level
> 0)
450 /* If we don't know the shape at compile time, we create an allocatable
451 temporary variable to hold the intermediate result, but only if
452 allocation on assignment is active. */
454 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
457 /* Skip the test for pure functions if -faggressive-function-elimination
459 if ((*e
)->value
.function
.esym
)
461 /* Don't create an array temporary for elemental functions. */
462 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
465 /* Only eliminate potentially impure functions if the
466 user specifically requested it. */
467 if (!flag_aggressive_function_elimination
468 && !(*e
)->value
.function
.esym
->attr
.pure
469 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
473 if ((*e
)->value
.function
.isym
)
475 /* Conversions are handled on the fly by the middle end,
476 transpose during trans-* stages and TRANSFER by the middle end. */
477 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
478 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
479 || gfc_inline_intrinsic_function_p (*e
))
482 /* Don't create an array temporary for elemental functions,
483 as this would be wasteful of memory.
484 FIXME: Create a scalar temporary during scalarization. */
485 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
488 if (!(*e
)->value
.function
.isym
->pure
)
492 expr_array
.safe_push (e
);
496 /* Auxiliary function to check if an expression is a temporary created by
500 is_fe_temp (gfc_expr
*e
)
502 if (e
->expr_type
!= EXPR_VARIABLE
)
505 return e
->symtree
->n
.sym
->attr
.fe_temp
;
508 /* Determine the length of a string, if it can be evaluated as a constant
509 expression. Return a newly allocated gfc_expr or NULL on failure.
510 If the user specified a substring which is potentially longer than
511 the string itself, the string will be padded with spaces, which
515 constant_string_length (gfc_expr
*e
)
525 length
= e
->ts
.u
.cl
->length
;
526 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
527 return gfc_copy_expr(length
);
530 /* Return length of substring, if constant. */
531 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
533 if (ref
->type
== REF_SUBSTRING
534 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
536 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
539 mpz_add_ui (res
->value
.integer
, value
, 1);
545 /* Return length of char symbol, if constant. */
547 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
548 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
549 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
555 /* Insert a block at the current position unless it has already
556 been inserted; in this case use the one already there. */
558 static gfc_namespace
*
563 /* If the block hasn't already been created, do so. */
564 if (inserted_block
== NULL
)
566 inserted_block
= XCNEW (gfc_code
);
567 inserted_block
->op
= EXEC_BLOCK
;
568 inserted_block
->loc
= (*current_code
)->loc
;
569 ns
= gfc_build_block_ns (current_ns
);
570 inserted_block
->ext
.block
.ns
= ns
;
571 inserted_block
->ext
.block
.assoc
= NULL
;
573 ns
->code
= *current_code
;
575 /* If the statement has a label, make sure it is transferred to
576 the newly created block. */
578 if ((*current_code
)->here
)
580 inserted_block
->here
= (*current_code
)->here
;
581 (*current_code
)->here
= NULL
;
584 inserted_block
->next
= (*current_code
)->next
;
585 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
586 (*current_code
)->next
= NULL
;
587 /* Insert the BLOCK at the right position. */
588 *current_code
= inserted_block
;
589 ns
->parent
= current_ns
;
592 ns
= inserted_block
->ext
.block
.ns
;
597 /* Returns a new expression (a variable) to be used in place of the old one,
598 with an optional assignment statement before the current statement to set
599 the value of the variable. Creates a new BLOCK for the statement if that
600 hasn't already been done and puts the statement, plus the newly created
601 variables, in that block. Special cases: If the expression is constant or
602 a temporary which has already been created, just copy it. */
605 create_var (gfc_expr
* e
, const char *vname
)
607 char name
[GFC_MAX_SYMBOL_LEN
+1];
608 gfc_symtree
*symtree
;
615 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
616 return gfc_copy_expr (e
);
618 ns
= insert_block ();
621 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
623 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
625 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
628 symbol
= symtree
->n
.sym
;
633 symbol
->as
= gfc_get_array_spec ();
634 symbol
->as
->rank
= e
->rank
;
636 if (e
->shape
== NULL
)
638 /* We don't know the shape at compile time, so we use an
640 symbol
->as
->type
= AS_DEFERRED
;
641 symbol
->attr
.allocatable
= 1;
645 symbol
->as
->type
= AS_EXPLICIT
;
646 /* Copy the shape. */
647 for (i
=0; i
<e
->rank
; i
++)
651 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
653 mpz_set_si (p
->value
.integer
, 1);
654 symbol
->as
->lower
[i
] = p
;
656 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
658 mpz_set (q
->value
.integer
, e
->shape
[i
]);
659 symbol
->as
->upper
[i
] = q
;
664 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
668 length
= constant_string_length (e
);
671 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
672 symbol
->ts
.u
.cl
->length
= length
;
675 symbol
->attr
.allocatable
= 1;
678 symbol
->attr
.flavor
= FL_VARIABLE
;
679 symbol
->attr
.referenced
= 1;
680 symbol
->attr
.dimension
= e
->rank
> 0;
681 symbol
->attr
.fe_temp
= 1;
682 gfc_commit_symbol (symbol
);
684 result
= gfc_get_expr ();
685 result
->expr_type
= EXPR_VARIABLE
;
687 result
->rank
= e
->rank
;
688 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
689 result
->symtree
= symtree
;
690 result
->where
= e
->where
;
693 result
->ref
= gfc_get_ref ();
694 result
->ref
->type
= REF_ARRAY
;
695 result
->ref
->u
.ar
.type
= AR_FULL
;
696 result
->ref
->u
.ar
.where
= e
->where
;
697 result
->ref
->u
.ar
.dimen
= e
->rank
;
698 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
699 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
700 if (warn_array_temporaries
)
701 gfc_warning (OPT_Warray_temporaries
,
702 "Creating array temporary at %L", &(e
->where
));
705 /* Generate the new assignment. */
706 n
= XCNEW (gfc_code
);
708 n
->loc
= (*current_code
)->loc
;
709 n
->next
= *changed_statement
;
710 n
->expr1
= gfc_copy_expr (result
);
712 *changed_statement
= n
;
718 /* Warn about function elimination. */
721 do_warn_function_elimination (gfc_expr
*e
)
723 if (e
->expr_type
!= EXPR_FUNCTION
)
725 if (e
->value
.function
.esym
)
726 gfc_warning (0, "Removing call to function %qs at %L",
727 e
->value
.function
.esym
->name
, &(e
->where
));
728 else if (e
->value
.function
.isym
)
729 gfc_warning (0, "Removing call to function %qs at %L",
730 e
->value
.function
.isym
->name
, &(e
->where
));
732 /* Callback function for the code walker for doing common function
733 elimination. This builds up the list of functions in the expression
734 and goes through them to detect duplicates, which it then replaces
738 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
739 void *data ATTRIBUTE_UNUSED
)
745 /* Don't do this optimization within OMP workshare or ASSOC lists. */
747 if (in_omp_workshare
|| in_assoc_list
)
753 expr_array
.release ();
755 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
757 /* Walk through all the functions. */
759 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
761 /* Skip if the function has been replaced by a variable already. */
762 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
769 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
772 newvar
= create_var (*ei
, "fcn");
774 if (warn_function_elimination
)
775 do_warn_function_elimination (*ej
);
778 *ej
= gfc_copy_expr (newvar
);
785 /* We did all the necessary walking in this function. */
790 /* Callback function for common function elimination, called from
791 gfc_code_walker. This keeps track of the current code, in order
792 to insert statements as needed. */
795 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
798 inserted_block
= NULL
;
799 changed_statement
= NULL
;
801 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
802 and allocation on assigment are prohibited inside WHERE, and finally
803 masking an expression would lead to wrong-code when replacing
806 b = sum(foo(a) + foo(a))
817 if ((*c
)->op
== EXEC_WHERE
)
827 /* Dummy function for expression call back, for use when we
828 really don't want to do any walking. */
831 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
832 void *data ATTRIBUTE_UNUSED
)
838 /* Dummy function for code callback, for use when we really
839 don't want to do anything. */
841 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
842 int *walk_subtrees ATTRIBUTE_UNUSED
,
843 void *data ATTRIBUTE_UNUSED
)
848 /* Code callback function for converting
855 This is because common function elimination would otherwise place the
856 temporary variables outside the loop. */
859 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
860 void *data ATTRIBUTE_UNUSED
)
863 gfc_code
*c_if1
, *c_if2
, *c_exit
;
865 gfc_expr
*e_not
, *e_cond
;
867 if (co
->op
!= EXEC_DO_WHILE
)
870 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
875 /* Generate the condition of the if statement, which is .not. the original
877 e_not
= gfc_get_expr ();
878 e_not
->ts
= e_cond
->ts
;
879 e_not
->where
= e_cond
->where
;
880 e_not
->expr_type
= EXPR_OP
;
881 e_not
->value
.op
.op
= INTRINSIC_NOT
;
882 e_not
->value
.op
.op1
= e_cond
;
884 /* Generate the EXIT statement. */
885 c_exit
= XCNEW (gfc_code
);
886 c_exit
->op
= EXEC_EXIT
;
887 c_exit
->ext
.which_construct
= co
;
888 c_exit
->loc
= co
->loc
;
890 /* Generate the IF statement. */
891 c_if2
= XCNEW (gfc_code
);
893 c_if2
->expr1
= e_not
;
894 c_if2
->next
= c_exit
;
895 c_if2
->loc
= co
->loc
;
897 /* ... plus the one to chain it to. */
898 c_if1
= XCNEW (gfc_code
);
900 c_if1
->block
= c_if2
;
901 c_if1
->loc
= co
->loc
;
903 /* Make the DO WHILE loop into a DO block by replacing the condition
904 with a true constant. */
905 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
907 /* Hang the generated if statement into the loop body. */
909 loopblock
= co
->block
->next
;
910 co
->block
->next
= c_if1
;
911 c_if1
->next
= loopblock
;
916 /* Code callback function for converting
929 because otherwise common function elimination would place the BLOCKs
930 into the wrong place. */
933 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
934 void *data ATTRIBUTE_UNUSED
)
937 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
939 if (co
->op
!= EXEC_IF
)
942 /* This loop starts out with the first ELSE statement. */
943 else_stmt
= co
->block
->block
;
945 while (else_stmt
!= NULL
)
949 /* If there is no condition, we're done. */
950 if (else_stmt
->expr1
== NULL
)
953 next_else
= else_stmt
->block
;
955 /* Generate the new IF statement. */
956 c_if2
= XCNEW (gfc_code
);
958 c_if2
->expr1
= else_stmt
->expr1
;
959 c_if2
->next
= else_stmt
->next
;
960 c_if2
->loc
= else_stmt
->loc
;
961 c_if2
->block
= next_else
;
963 /* ... plus the one to chain it to. */
964 c_if1
= XCNEW (gfc_code
);
966 c_if1
->block
= c_if2
;
967 c_if1
->loc
= else_stmt
->loc
;
969 /* Insert the new IF after the ELSE. */
970 else_stmt
->expr1
= NULL
;
971 else_stmt
->next
= c_if1
;
972 else_stmt
->block
= NULL
;
974 else_stmt
= next_else
;
976 /* Don't walk subtrees. */
980 /* Optimize a namespace, including all contained namespaces. */
983 optimize_namespace (gfc_namespace
*ns
)
985 gfc_namespace
*saved_ns
= gfc_current_ns
;
990 in_assoc_list
= false;
991 in_omp_workshare
= false;
993 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
994 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
995 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
996 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
997 if (flag_inline_matmul_limit
!= 0)
998 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1001 /* BLOCKs are handled in the expression walker below. */
1002 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1004 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1005 optimize_namespace (ns
);
1007 gfc_current_ns
= saved_ns
;
1010 /* Handle dependencies for allocatable strings which potentially redefine
1011 themselves in an assignment. */
1014 realloc_strings (gfc_namespace
*ns
)
1017 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1019 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1021 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1022 realloc_strings (ns
);
1028 optimize_reduction (gfc_namespace
*ns
)
1031 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1032 callback_reduction
, NULL
);
1034 /* BLOCKs are handled in the expression walker below. */
1035 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1037 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1038 optimize_reduction (ns
);
1042 /* Replace code like
1045 a = matmul(b,c) ; a = a + d
1046 where the array function is not elemental and not allocatable
1047 and does not depend on the left-hand side.
1051 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1056 if (e
->expr_type
== EXPR_OP
)
1058 switch (e
->value
.op
.op
)
1060 /* Unary operators and exponentiation: Only look at a single
1063 case INTRINSIC_UPLUS
:
1064 case INTRINSIC_UMINUS
:
1065 case INTRINSIC_PARENTHESES
:
1066 case INTRINSIC_POWER
:
1067 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1071 case INTRINSIC_CONCAT
:
1072 /* Do not do string concatenations. */
1076 /* Binary operators. */
1077 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1080 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1086 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1087 && ! (e
->value
.function
.esym
1088 && (e
->value
.function
.esym
->attr
.elemental
1089 || e
->value
.function
.esym
->attr
.allocatable
1090 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1091 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1092 && ! (e
->value
.function
.isym
1093 && (e
->value
.function
.isym
->elemental
1094 || e
->ts
.type
!= c
->expr1
->ts
.type
1095 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1096 && ! gfc_inline_intrinsic_function_p (e
))
1102 /* Insert a new assignment statement after the current one. */
1103 n
= XCNEW (gfc_code
);
1104 n
->op
= EXEC_ASSIGN
;
1109 n
->expr1
= gfc_copy_expr (c
->expr1
);
1110 n
->expr2
= c
->expr2
;
1111 new_expr
= gfc_copy_expr (c
->expr1
);
1119 /* Nothing to optimize. */
1123 /* Remove unneeded TRIMs at the end of expressions. */
1126 remove_trim (gfc_expr
*rhs
)
1132 /* Check for a // b // trim(c). Looping is probably not
1133 necessary because the parser usually generates
1134 (// (// a b ) trim(c) ) , but better safe than sorry. */
1136 while (rhs
->expr_type
== EXPR_OP
1137 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1138 rhs
= rhs
->value
.op
.op2
;
1140 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1141 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1143 strip_function_call (rhs
);
1144 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1152 /* Optimizations for an assignment. */
1155 optimize_assignment (gfc_code
* c
)
1157 gfc_expr
*lhs
, *rhs
;
1162 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1164 /* Optimize a = trim(b) to a = b. */
1167 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1168 if (is_empty_string (rhs
))
1169 rhs
->value
.character
.length
= 0;
1172 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1173 optimize_binop_array_assignment (c
, &rhs
, false);
1177 /* Remove an unneeded function call, modifying the expression.
1178 This replaces the function call with the value of its
1179 first argument. The rest of the argument list is freed. */
1182 strip_function_call (gfc_expr
*e
)
1185 gfc_actual_arglist
*a
;
1187 a
= e
->value
.function
.actual
;
1189 /* We should have at least one argument. */
1190 gcc_assert (a
->expr
!= NULL
);
1194 /* Free the remaining arglist, if any. */
1196 gfc_free_actual_arglist (a
->next
);
1198 /* Graft the argument expression onto the original function. */
1204 /* Optimization of lexical comparison functions. */
1207 optimize_lexical_comparison (gfc_expr
*e
)
1209 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1212 switch (e
->value
.function
.isym
->id
)
1215 return optimize_comparison (e
, INTRINSIC_LE
);
1218 return optimize_comparison (e
, INTRINSIC_GE
);
1221 return optimize_comparison (e
, INTRINSIC_GT
);
1224 return optimize_comparison (e
, INTRINSIC_LT
);
1232 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1233 do CHARACTER because of possible pessimization involving character
1237 combine_array_constructor (gfc_expr
*e
)
1240 gfc_expr
*op1
, *op2
;
1243 gfc_constructor
*c
, *new_c
;
1244 gfc_constructor_base oldbase
, newbase
;
1247 /* Array constructors have rank one. */
1251 /* Don't try to combine association lists, this makes no sense
1252 and leads to an ICE. */
1256 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1257 if (forall_level
> 0)
1260 op1
= e
->value
.op
.op1
;
1261 op2
= e
->value
.op
.op2
;
1263 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1264 scalar_first
= false;
1265 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1267 scalar_first
= true;
1268 op1
= e
->value
.op
.op2
;
1269 op2
= e
->value
.op
.op1
;
1274 if (op2
->ts
.type
== BT_CHARACTER
)
1277 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1279 oldbase
= op1
->value
.constructor
;
1281 e
->expr_type
= EXPR_ARRAY
;
1283 for (c
= gfc_constructor_first (oldbase
); c
;
1284 c
= gfc_constructor_next (c
))
1286 new_expr
= gfc_get_expr ();
1287 new_expr
->ts
= e
->ts
;
1288 new_expr
->expr_type
= EXPR_OP
;
1289 new_expr
->rank
= c
->expr
->rank
;
1290 new_expr
->where
= c
->where
;
1291 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1295 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1296 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1300 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1301 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1304 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1305 new_c
->iterator
= c
->iterator
;
1309 gfc_free_expr (op1
);
1310 gfc_free_expr (op2
);
1311 gfc_free_expr (scalar
);
1313 e
->value
.constructor
= newbase
;
1317 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1318 2**k into ishift(1,k) */
1321 optimize_power (gfc_expr
*e
)
1323 gfc_expr
*op1
, *op2
;
1324 gfc_expr
*iand
, *ishft
;
1326 if (e
->ts
.type
!= BT_INTEGER
)
1329 op1
= e
->value
.op
.op1
;
1331 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1334 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1336 gfc_free_expr (op1
);
1338 op2
= e
->value
.op
.op2
;
1343 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1344 "_internal_iand", e
->where
, 2, op2
,
1345 gfc_get_int_expr (e
->ts
.kind
,
1348 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1349 "_internal_ishft", e
->where
, 2, iand
,
1350 gfc_get_int_expr (e
->ts
.kind
,
1353 e
->value
.op
.op
= INTRINSIC_MINUS
;
1354 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1355 e
->value
.op
.op2
= ishft
;
1358 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1360 gfc_free_expr (op1
);
1362 op2
= e
->value
.op
.op2
;
1366 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1367 "_internal_ishft", e
->where
, 2,
1368 gfc_get_int_expr (e
->ts
.kind
,
1375 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1377 op2
= e
->value
.op
.op2
;
1381 gfc_free_expr (op1
);
1382 gfc_free_expr (op2
);
1384 e
->expr_type
= EXPR_CONSTANT
;
1385 e
->value
.op
.op1
= NULL
;
1386 e
->value
.op
.op2
= NULL
;
1387 mpz_init_set_si (e
->value
.integer
, 1);
1388 /* Typespec and location are still OK. */
1395 /* Recursive optimization of operators. */
1398 optimize_op (gfc_expr
*e
)
1402 gfc_intrinsic_op op
= e
->value
.op
.op
;
1406 /* Only use new-style comparisons. */
1409 case INTRINSIC_EQ_OS
:
1413 case INTRINSIC_GE_OS
:
1417 case INTRINSIC_LE_OS
:
1421 case INTRINSIC_NE_OS
:
1425 case INTRINSIC_GT_OS
:
1429 case INTRINSIC_LT_OS
:
1445 changed
= optimize_comparison (e
, op
);
1448 /* Look at array constructors. */
1449 case INTRINSIC_PLUS
:
1450 case INTRINSIC_MINUS
:
1451 case INTRINSIC_TIMES
:
1452 case INTRINSIC_DIVIDE
:
1453 return combine_array_constructor (e
) || changed
;
1455 case INTRINSIC_POWER
:
1456 return optimize_power (e
);
1467 /* Return true if a constant string contains only blanks. */
1470 is_empty_string (gfc_expr
*e
)
1474 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1477 for (i
=0; i
< e
->value
.character
.length
; i
++)
1479 if (e
->value
.character
.string
[i
] != ' ')
1487 /* Insert a call to the intrinsic len_trim. Use a different name for
1488 the symbol tree so we don't run into trouble when the user has
1489 renamed len_trim for some reason. */
1492 get_len_trim_call (gfc_expr
*str
, int kind
)
1495 gfc_actual_arglist
*actual_arglist
, *next
;
1497 fcn
= gfc_get_expr ();
1498 fcn
->expr_type
= EXPR_FUNCTION
;
1499 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1500 actual_arglist
= gfc_get_actual_arglist ();
1501 actual_arglist
->expr
= str
;
1502 next
= gfc_get_actual_arglist ();
1503 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1504 actual_arglist
->next
= next
;
1506 fcn
->value
.function
.actual
= actual_arglist
;
1507 fcn
->where
= str
->where
;
1508 fcn
->ts
.type
= BT_INTEGER
;
1509 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1511 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1512 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1513 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1514 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1515 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1516 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1517 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1518 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1523 /* Optimize expressions for equality. */
1526 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1528 gfc_expr
*op1
, *op2
;
1532 gfc_actual_arglist
*firstarg
, *secondarg
;
1534 if (e
->expr_type
== EXPR_OP
)
1538 op1
= e
->value
.op
.op1
;
1539 op2
= e
->value
.op
.op2
;
1541 else if (e
->expr_type
== EXPR_FUNCTION
)
1543 /* One of the lexical comparison functions. */
1544 firstarg
= e
->value
.function
.actual
;
1545 secondarg
= firstarg
->next
;
1546 op1
= firstarg
->expr
;
1547 op2
= secondarg
->expr
;
1552 /* Strip off unneeded TRIM calls from string comparisons. */
1554 change
= remove_trim (op1
);
1556 if (remove_trim (op2
))
1559 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1560 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1561 handles them well). However, there are also cases that need a non-scalar
1562 argument. For example the any intrinsic. See PR 45380. */
1566 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1568 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1569 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1571 bool empty_op1
, empty_op2
;
1572 empty_op1
= is_empty_string (op1
);
1573 empty_op2
= is_empty_string (op2
);
1575 if (empty_op1
|| empty_op2
)
1581 /* This can only happen when an error for comparing
1582 characters of different kinds has already been issued. */
1583 if (empty_op1
&& empty_op2
)
1586 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1587 str
= empty_op1
? op2
: op1
;
1589 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1593 gfc_free_expr (op1
);
1595 gfc_free_expr (op2
);
1599 e
->value
.op
.op1
= fcn
;
1600 e
->value
.op
.op2
= zero
;
1605 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1607 if (flag_finite_math_only
1608 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1609 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1611 eq
= gfc_dep_compare_expr (op1
, op2
);
1614 /* Replace A // B < A // C with B < C, and A // B < C // B
1616 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1617 && op1
->expr_type
== EXPR_OP
1618 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1619 && op2
->expr_type
== EXPR_OP
1620 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1622 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1623 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1624 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1625 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1627 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1629 /* Watch out for 'A ' // x vs. 'A' // x. */
1631 if (op1_left
->expr_type
== EXPR_CONSTANT
1632 && op2_left
->expr_type
== EXPR_CONSTANT
1633 && op1_left
->value
.character
.length
1634 != op2_left
->value
.character
.length
)
1642 firstarg
->expr
= op1_right
;
1643 secondarg
->expr
= op2_right
;
1647 e
->value
.op
.op1
= op1_right
;
1648 e
->value
.op
.op2
= op2_right
;
1650 optimize_comparison (e
, op
);
1654 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1660 firstarg
->expr
= op1_left
;
1661 secondarg
->expr
= op2_left
;
1665 e
->value
.op
.op1
= op1_left
;
1666 e
->value
.op
.op2
= op2_left
;
1669 optimize_comparison (e
, op
);
1676 /* eq can only be -1, 0 or 1 at this point. */
1704 gfc_internal_error ("illegal OP in optimize_comparison");
1708 /* Replace the expression by a constant expression. The typespec
1709 and where remains the way it is. */
1712 e
->expr_type
= EXPR_CONSTANT
;
1713 e
->value
.logical
= result
;
1721 /* Optimize a trim function by replacing it with an equivalent substring
1722 involving a call to len_trim. This only works for expressions where
1723 variables are trimmed. Return true if anything was modified. */
1726 optimize_trim (gfc_expr
*e
)
1731 gfc_ref
**rr
= NULL
;
1733 /* Don't do this optimization within an argument list, because
1734 otherwise aliasing issues may occur. */
1736 if (count_arglist
!= 1)
1739 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1740 || e
->value
.function
.isym
== NULL
1741 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1744 a
= e
->value
.function
.actual
->expr
;
1746 if (a
->expr_type
!= EXPR_VARIABLE
)
1749 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1751 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1754 /* Follow all references to find the correct place to put the newly
1755 created reference. FIXME: Also handle substring references and
1756 array references. Array references cause strange regressions at
1761 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1763 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1768 strip_function_call (e
);
1773 /* Create the reference. */
1775 ref
= gfc_get_ref ();
1776 ref
->type
= REF_SUBSTRING
;
1778 /* Set the start of the reference. */
1780 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1782 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1784 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1786 /* Set the end of the reference to the call to len_trim. */
1788 ref
->u
.ss
.end
= fcn
;
1789 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1794 /* Optimize minloc(b), where b is rank 1 array, into
1795 (/ minloc(b, dim=1) /), and similarly for maxloc,
1796 as the latter forms are expanded inline. */
1799 optimize_minmaxloc (gfc_expr
**e
)
1802 gfc_actual_arglist
*a
;
1806 || fn
->value
.function
.actual
== NULL
1807 || fn
->value
.function
.actual
->expr
== NULL
1808 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1811 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1812 (*e
)->shape
= fn
->shape
;
1815 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1817 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1818 strcpy (name
, fn
->value
.function
.name
);
1819 p
= strstr (name
, "loc0");
1821 fn
->value
.function
.name
= gfc_get_string (name
);
1822 if (fn
->value
.function
.actual
->next
)
1824 a
= fn
->value
.function
.actual
->next
;
1825 gcc_assert (a
->expr
== NULL
);
1829 a
= gfc_get_actual_arglist ();
1830 fn
->value
.function
.actual
->next
= a
;
1832 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1834 mpz_set_ui (a
->expr
->value
.integer
, 1);
1837 /* Callback function for code checking that we do not pass a DO variable to an
1838 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1841 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1842 void *data ATTRIBUTE_UNUSED
)
1846 gfc_formal_arglist
*f
;
1847 gfc_actual_arglist
*a
;
1852 /* If the doloop_list grew, we have to truncate it here. */
1854 if ((unsigned) doloop_level
< doloop_list
.length())
1855 doloop_list
.truncate (doloop_level
);
1861 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1862 doloop_list
.safe_push (co
);
1864 doloop_list
.safe_push ((gfc_code
*) NULL
);
1869 if (co
->resolved_sym
== NULL
)
1872 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1874 /* Withot a formal arglist, there is only unknown INTENT,
1875 which we don't check for. */
1883 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1890 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1892 if (a
->expr
&& a
->expr
->symtree
1893 && a
->expr
->symtree
->n
.sym
== do_sym
)
1895 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1896 gfc_error_now ("Variable %qs at %L set to undefined "
1897 "value inside loop beginning at %L as "
1898 "INTENT(OUT) argument to subroutine %qs",
1899 do_sym
->name
, &a
->expr
->where
,
1900 &doloop_list
[i
]->loc
,
1901 co
->symtree
->n
.sym
->name
);
1902 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1903 gfc_error_now ("Variable %qs at %L not definable inside "
1904 "loop beginning at %L as INTENT(INOUT) "
1905 "argument to subroutine %qs",
1906 do_sym
->name
, &a
->expr
->where
,
1907 &doloop_list
[i
]->loc
,
1908 co
->symtree
->n
.sym
->name
);
1922 /* Callback function for functions checking that we do not pass a DO variable
1923 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1926 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1927 void *data ATTRIBUTE_UNUSED
)
1929 gfc_formal_arglist
*f
;
1930 gfc_actual_arglist
*a
;
1936 if (expr
->expr_type
!= EXPR_FUNCTION
)
1939 /* Intrinsic functions don't modify their arguments. */
1941 if (expr
->value
.function
.isym
)
1944 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1946 /* Without a formal arglist, there is only unknown INTENT,
1947 which we don't check for. */
1951 a
= expr
->value
.function
.actual
;
1955 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1962 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1964 if (a
->expr
&& a
->expr
->symtree
1965 && a
->expr
->symtree
->n
.sym
== do_sym
)
1967 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1968 gfc_error_now ("Variable %qs at %L set to undefined value "
1969 "inside loop beginning at %L as INTENT(OUT) "
1970 "argument to function %qs", do_sym
->name
,
1971 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1972 expr
->symtree
->n
.sym
->name
);
1973 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1974 gfc_error_now ("Variable %qs at %L not definable inside loop"
1975 " beginning at %L as INTENT(INOUT) argument to"
1976 " function %qs", do_sym
->name
,
1977 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1978 expr
->symtree
->n
.sym
->name
);
1989 doloop_warn (gfc_namespace
*ns
)
1991 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1994 /* This selction deals with inlining calls to MATMUL. */
1996 /* Auxiliary function to build and simplify an array inquiry function.
1997 dim is zero-based. */
2000 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2003 gfc_expr
*dim_arg
, *kind
;
2009 case GFC_ISYM_LBOUND
:
2010 name
= "_gfortran_lbound";
2013 case GFC_ISYM_UBOUND
:
2014 name
= "_gfortran_ubound";
2018 name
= "_gfortran_size";
2025 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2026 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2027 gfc_index_integer_kind
);
2029 ec
= gfc_copy_expr (e
);
2030 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2032 gfc_simplify_expr (fcn
, 0);
2036 /* Builds a logical expression. */
2039 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2044 ts
.type
= BT_LOGICAL
;
2045 ts
.kind
= gfc_default_logical_kind
;
2046 res
= gfc_get_expr ();
2047 res
->where
= e1
->where
;
2048 res
->expr_type
= EXPR_OP
;
2049 res
->value
.op
.op
= op
;
2050 res
->value
.op
.op1
= e1
;
2051 res
->value
.op
.op2
= e2
;
2058 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2059 compatible typespecs. */
2062 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2066 res
= gfc_get_expr ();
2068 res
->where
= e1
->where
;
2069 res
->expr_type
= EXPR_OP
;
2070 res
->value
.op
.op
= op
;
2071 res
->value
.op
.op1
= e1
;
2072 res
->value
.op
.op2
= e2
;
2073 gfc_simplify_expr (res
, 0);
2077 /* Generate the IF statement for a runtime check if we want to do inlining or
2078 not - putting in the code for both branches and putting it into the syntax
2079 tree is the caller's responsibility. For fixed array sizes, this should be
2080 removed by DCE. Only called for rank-two matrices A and B. */
2083 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2085 gfc_expr
*inline_limit
;
2086 gfc_code
*if_1
, *if_2
, *else_2
;
2087 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2091 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2093 /* Calculation is done in real to avoid integer overflow. */
2095 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2097 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2099 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2102 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2103 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2104 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2108 ts
.kind
= gfc_default_real_kind
;
2109 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2110 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2111 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2113 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2114 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2116 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2117 gfc_simplify_expr (cond
, 0);
2119 else_2
= XCNEW (gfc_code
);
2120 else_2
->op
= EXEC_IF
;
2121 else_2
->loc
= a
->where
;
2123 if_2
= XCNEW (gfc_code
);
2126 if_2
->loc
= a
->where
;
2127 if_2
->block
= else_2
;
2129 if_1
= XCNEW (gfc_code
);
2132 if_1
->loc
= a
->where
;
2138 /* Insert code to issue a runtime error if the expressions are not equal. */
2141 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2144 gfc_code
*if_1
, *if_2
;
2146 gfc_actual_arglist
*a1
, *a2
, *a3
;
2148 gcc_assert (e1
->where
.lb
);
2149 /* Build the call to runtime_error. */
2150 c
= XCNEW (gfc_code
);
2154 /* Get a null-terminated message string. */
2156 a1
= gfc_get_actual_arglist ();
2157 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2158 msg
, strlen(msg
)+1);
2161 /* Pass the value of the first expression. */
2162 a2
= gfc_get_actual_arglist ();
2163 a2
->expr
= gfc_copy_expr (e1
);
2166 /* Pass the value of the second expression. */
2167 a3
= gfc_get_actual_arglist ();
2168 a3
->expr
= gfc_copy_expr (e2
);
2171 gfc_check_fe_runtime_error (c
->ext
.actual
);
2172 gfc_resolve_fe_runtime_error (c
);
2174 if_2
= XCNEW (gfc_code
);
2176 if_2
->loc
= e1
->where
;
2179 if_1
= XCNEW (gfc_code
);
2182 if_1
->loc
= e1
->where
;
2184 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2185 gfc_simplify_expr (cond
, 0);
2191 /* Handle matrix reallocation. Caller is responsible to insert into
2194 For the two-dimensional case, build
2196 if (allocated(c)) then
2197 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2199 allocate (c(size(a,1), size(b,2)))
2202 allocate (c(size(a,1),size(b,2)))
2205 and for the other cases correspondingly.
2209 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2210 enum matrix_case m_case
)
2213 gfc_expr
*allocated
, *alloc_expr
;
2214 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2215 gfc_code
*else_alloc
;
2216 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2218 gfc_expr
*cond
, *ne1
, *ne2
;
2220 if (warn_realloc_lhs
)
2221 gfc_warning (OPT_Wrealloc_lhs
,
2222 "Code for reallocating the allocatable array at %L will "
2223 "be added", &c
->where
);
2225 alloc_expr
= gfc_copy_expr (c
);
2227 ar
= gfc_find_array_ref (alloc_expr
);
2228 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2230 /* c comes in as a full ref. Change it into a copy and make it into an
2231 element ref so it has the right form for for ALLOCATE. In the same
2232 switch statement, also generate the size comparison for the secod IF
2235 ar
->type
= AR_ELEMENT
;
2240 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2241 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2242 ne1
= build_logical_expr (INTRINSIC_NE
,
2243 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2244 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2245 ne2
= build_logical_expr (INTRINSIC_NE
,
2246 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2247 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2248 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2252 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2253 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2255 ne1
= build_logical_expr (INTRINSIC_NE
,
2256 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2257 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2258 ne2
= build_logical_expr (INTRINSIC_NE
,
2259 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2260 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2261 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2265 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2266 cond
= build_logical_expr (INTRINSIC_NE
,
2267 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2268 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2272 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2273 cond
= build_logical_expr (INTRINSIC_NE
,
2274 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2275 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2283 gfc_simplify_expr (cond
, 0);
2285 /* We need two identical allocate statements in two
2286 branches of the IF statement. */
2288 allocate1
= XCNEW (gfc_code
);
2289 allocate1
->op
= EXEC_ALLOCATE
;
2290 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2291 allocate1
->loc
= c
->where
;
2292 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2294 allocate_else
= XCNEW (gfc_code
);
2295 allocate_else
->op
= EXEC_ALLOCATE
;
2296 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2297 allocate_else
->loc
= c
->where
;
2298 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2300 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2301 "_gfortran_allocated", c
->where
,
2302 1, gfc_copy_expr (c
));
2304 deallocate
= XCNEW (gfc_code
);
2305 deallocate
->op
= EXEC_DEALLOCATE
;
2306 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2307 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2308 deallocate
->next
= allocate1
;
2309 deallocate
->loc
= c
->where
;
2311 if_size_2
= XCNEW (gfc_code
);
2312 if_size_2
->op
= EXEC_IF
;
2313 if_size_2
->expr1
= cond
;
2314 if_size_2
->loc
= c
->where
;
2315 if_size_2
->next
= deallocate
;
2317 if_size_1
= XCNEW (gfc_code
);
2318 if_size_1
->op
= EXEC_IF
;
2319 if_size_1
->block
= if_size_2
;
2320 if_size_1
->loc
= c
->where
;
2322 else_alloc
= XCNEW (gfc_code
);
2323 else_alloc
->op
= EXEC_IF
;
2324 else_alloc
->loc
= c
->where
;
2325 else_alloc
->next
= allocate_else
;
2327 if_alloc_2
= XCNEW (gfc_code
);
2328 if_alloc_2
->op
= EXEC_IF
;
2329 if_alloc_2
->expr1
= allocated
;
2330 if_alloc_2
->loc
= c
->where
;
2331 if_alloc_2
->next
= if_size_1
;
2332 if_alloc_2
->block
= else_alloc
;
2334 if_alloc_1
= XCNEW (gfc_code
);
2335 if_alloc_1
->op
= EXEC_IF
;
2336 if_alloc_1
->block
= if_alloc_2
;
2337 if_alloc_1
->loc
= c
->where
;
2342 /* Callback function for has_function_or_op. */
2345 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2346 void *data ATTRIBUTE_UNUSED
)
2351 return (*e
)->expr_type
== EXPR_FUNCTION
2352 || (*e
)->expr_type
== EXPR_OP
;
2355 /* Returns true if the expression contains a function. */
2358 has_function_or_op (gfc_expr
**e
)
2363 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2366 /* Freeze (assign to a temporary variable) a single expression. */
2369 freeze_expr (gfc_expr
**ep
)
2372 if (has_function_or_op (ep
))
2374 ne
= create_var (*ep
, "freeze");
2379 /* Go through an expression's references and assign them to temporary
2380 variables if they contain functions. This is usually done prior to
2381 front-end scalarization to avoid multiple invocations of functions. */
2384 freeze_references (gfc_expr
*e
)
2390 for (r
=e
->ref
; r
; r
=r
->next
)
2392 if (r
->type
== REF_SUBSTRING
)
2394 if (r
->u
.ss
.start
!= NULL
)
2395 freeze_expr (&r
->u
.ss
.start
);
2397 if (r
->u
.ss
.end
!= NULL
)
2398 freeze_expr (&r
->u
.ss
.end
);
2400 else if (r
->type
== REF_ARRAY
)
2409 for (i
=0; i
<ar
->dimen
; i
++)
2411 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2413 freeze_expr (&ar
->start
[i
]);
2414 freeze_expr (&ar
->end
[i
]);
2415 freeze_expr (&ar
->stride
[i
]);
2417 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2419 freeze_expr (&ar
->start
[i
]);
2425 for (i
=0; i
<ar
->dimen
; i
++)
2426 freeze_expr (&ar
->start
[i
]);
2436 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2439 convert_to_index_kind (gfc_expr
*e
)
2443 gcc_assert (e
!= NULL
);
2445 res
= gfc_copy_expr (e
);
2447 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2449 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2453 ts
.type
= BT_INTEGER
;
2454 ts
.kind
= gfc_index_integer_kind
;
2456 gfc_convert_type_warn (e
, &ts
, 2, 0);
2462 /* Function to create a DO loop including creation of the
2463 iteration variable. gfc_expr are copied.*/
2466 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2467 gfc_namespace
*ns
, char *vname
)
2470 char name
[GFC_MAX_SYMBOL_LEN
+1];
2471 gfc_symtree
*symtree
;
2476 /* Create an expression for the iteration variable. */
2478 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2480 sprintf (name
, "__var_%d_do", var_num
++);
2483 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2486 /* Create the loop variable. */
2488 symbol
= symtree
->n
.sym
;
2489 symbol
->ts
.type
= BT_INTEGER
;
2490 symbol
->ts
.kind
= gfc_index_integer_kind
;
2491 symbol
->attr
.flavor
= FL_VARIABLE
;
2492 symbol
->attr
.referenced
= 1;
2493 symbol
->attr
.dimension
= 0;
2494 symbol
->attr
.fe_temp
= 1;
2495 gfc_commit_symbol (symbol
);
2497 i
= gfc_get_expr ();
2498 i
->expr_type
= EXPR_VARIABLE
;
2502 i
->symtree
= symtree
;
2504 /* ... and the nested DO statements. */
2505 n
= XCNEW (gfc_code
);
2508 n
->ext
.iterator
= gfc_get_iterator ();
2509 n
->ext
.iterator
->var
= i
;
2510 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2511 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2513 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2515 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2518 n2
= XCNEW (gfc_code
);
2526 /* Get the upper bound of the DO loops for matmul along a dimension. This
2530 get_size_m1 (gfc_expr
*e
, int dimen
)
2535 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2537 res
= gfc_get_constant_expr (BT_INTEGER
,
2538 gfc_index_integer_kind
, &e
->where
);
2539 mpz_sub_ui (res
->value
.integer
, size
, 1);
2544 res
= get_operand (INTRINSIC_MINUS
,
2545 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2546 gfc_get_int_expr (gfc_index_integer_kind
,
2548 gfc_simplify_expr (res
, 0);
2554 /* Function to return a scalarized expression. It is assumed that indices are
2555 zero based to make generation of DO loops easier. A zero as index will
2556 access the first element along a dimension. Single element references will
2557 be skipped. A NULL as an expression will be replaced by a full reference.
2558 This assumes that the index loops have gfc_index_integer_kind, and that all
2559 references have been frozen. */
2562 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2571 e
= gfc_copy_expr(e_in
);
2575 ar
= gfc_find_array_ref (e
);
2577 /* We scalarize count_index variables, reducing the rank by count_index. */
2579 e
->rank
= rank
- count_index
;
2581 was_fullref
= ar
->type
== AR_FULL
;
2584 ar
->type
= AR_ELEMENT
;
2586 ar
->type
= AR_SECTION
;
2588 /* Loop over the indices. For each index, create the expression
2589 index * stride + lbound(e, dim). */
2592 for (i
=0; i
< ar
->dimen
; i
++)
2594 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2596 if (index
[i_index
] != NULL
)
2598 gfc_expr
*lbound
, *nindex
;
2601 loopvar
= gfc_copy_expr (index
[i_index
]);
2607 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2608 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2612 ts
.type
= BT_INTEGER
;
2613 ts
.kind
= gfc_index_integer_kind
;
2614 gfc_convert_type (tmp
, &ts
, 2);
2616 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2621 /* Calculate the lower bound of the expression. */
2624 lbound
= gfc_copy_expr (ar
->start
[i
]);
2625 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2629 ts
.type
= BT_INTEGER
;
2630 ts
.kind
= gfc_index_integer_kind
;
2631 gfc_convert_type (lbound
, &ts
, 2);
2640 lbound_e
= gfc_copy_expr (e_in
);
2642 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2643 if (ref
->type
== REF_ARRAY
2644 && (ref
->u
.ar
.type
== AR_FULL
2645 || ref
->u
.ar
.type
== AR_SECTION
))
2650 gfc_free_ref_list (ref
->next
);
2656 /* Look at full individual sections, like a(:). The first index
2657 is the lbound of a full ref. */
2663 for (j
= 0; j
< ar
->dimen
; j
++)
2665 gfc_free_expr (ar
->start
[j
]);
2666 ar
->start
[j
] = NULL
;
2667 gfc_free_expr (ar
->end
[j
]);
2669 gfc_free_expr (ar
->stride
[j
]);
2670 ar
->stride
[j
] = NULL
;
2673 /* We have to get rid of the shape, if there is one. Do
2674 so by freeing it and calling gfc_resolve to rebuild
2675 it, if necessary. */
2677 if (lbound_e
->shape
)
2678 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2680 lbound_e
->rank
= ar
->dimen
;
2681 gfc_resolve_expr (lbound_e
);
2683 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2685 gfc_free_expr (lbound_e
);
2688 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2690 gfc_free_expr (ar
->start
[i
]);
2691 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2693 gfc_free_expr (ar
->end
[i
]);
2695 gfc_free_expr (ar
->stride
[i
]);
2696 ar
->stride
[i
] = NULL
;
2697 gfc_simplify_expr (ar
->start
[i
], 0);
2699 else if (was_fullref
)
2701 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2710 /* Helper function to check for a dimen vector as subscript. */
2713 has_dimen_vector_ref (gfc_expr
*e
)
2718 ar
= gfc_find_array_ref (e
);
2720 if (ar
->type
== AR_FULL
)
2723 for (i
=0; i
<ar
->dimen
; i
++)
2724 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2730 /* If handed an expression of the form
2734 check if A can be handled by matmul and return if there is an uneven number
2735 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2736 otherwise. The caller has to check for the correct rank. */
2739 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2746 if (e
->expr_type
== EXPR_VARIABLE
)
2748 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2751 else if (e
->expr_type
== EXPR_FUNCTION
)
2753 if (e
->value
.function
.isym
== NULL
)
2756 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2758 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2759 *transpose
= !*transpose
;
2765 e
= e
->value
.function
.actual
->expr
;
2772 /* Inline assignments of the form c = matmul(a,b).
2773 Handle only the cases currently where b and c are rank-two arrays.
2775 This basically translates the code to
2781 do k=0, size(a, 2)-1
2782 do i=0, size(a, 1)-1
2783 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2784 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2785 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2786 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2795 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2796 void *data ATTRIBUTE_UNUSED
)
2799 gfc_expr
*expr1
, *expr2
;
2800 gfc_expr
*matrix_a
, *matrix_b
;
2801 gfc_actual_arglist
*a
, *b
;
2802 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2804 gfc_expr
*u1
, *u2
, *u3
;
2806 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2808 gfc_expr
*var_1
, *var_2
, *var_3
;
2811 gfc_intrinsic_op op_times
, op_plus
;
2812 enum matrix_case m_case
;
2814 gfc_code
*if_limit
= NULL
;
2815 gfc_code
**next_code_point
;
2816 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2818 if (co
->op
!= EXEC_ASSIGN
)
2824 /* For now don't do anything in OpenMP workshare, it confuses
2825 its translation, which expects only the allowed statements in there.
2826 We should figure out how to parallelize this eventually. */
2827 if (in_omp_workshare
)
2832 if (expr2
->expr_type
!= EXPR_FUNCTION
2833 || expr2
->value
.function
.isym
== NULL
2834 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2838 inserted_block
= NULL
;
2839 changed_statement
= NULL
;
2841 a
= expr2
->value
.function
.actual
;
2842 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2843 if (transpose_a
|| matrix_a
== NULL
)
2847 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2848 if (matrix_b
== NULL
)
2851 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2852 || has_dimen_vector_ref (matrix_b
))
2855 /* We do not handle data dependencies yet. */
2856 if (gfc_check_dependency (expr1
, matrix_a
, true)
2857 || gfc_check_dependency (expr1
, matrix_b
, true))
2860 if (matrix_a
->rank
== 2)
2862 if (matrix_b
->rank
== 1)
2874 /* Vector * Transpose(B) not handled yet. */
2884 ns
= insert_block ();
2886 /* Assign the type of the zero expression for initializing the resulting
2887 array, and the expression (+ and * for real, integer and complex;
2888 .and. and .or for logical. */
2890 switch(expr1
->ts
.type
)
2893 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2894 op_times
= INTRINSIC_TIMES
;
2895 op_plus
= INTRINSIC_PLUS
;
2899 op_times
= INTRINSIC_AND
;
2900 op_plus
= INTRINSIC_OR
;
2901 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2905 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2907 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2908 op_times
= INTRINSIC_TIMES
;
2909 op_plus
= INTRINSIC_PLUS
;
2913 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2915 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2916 op_times
= INTRINSIC_TIMES
;
2917 op_plus
= INTRINSIC_PLUS
;
2925 current_code
= &ns
->code
;
2927 /* Freeze the references, keeping track of how many temporary variables were
2930 freeze_references (matrix_a
);
2931 freeze_references (matrix_b
);
2932 freeze_references (expr1
);
2935 next_code_point
= current_code
;
2938 next_code_point
= &ns
->code
;
2939 for (i
=0; i
<n_vars
; i
++)
2940 next_code_point
= &(*next_code_point
)->next
;
2943 /* Take care of the inline flag. If the limit check evaluates to a
2944 constant, dead code elimination will eliminate the unneeded branch. */
2946 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2948 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2950 /* Insert the original statement into the else branch. */
2951 if_limit
->block
->block
->next
= co
;
2954 /* ... and the new ones go into the original one. */
2955 *next_code_point
= if_limit
;
2956 next_code_point
= &if_limit
->block
->next
;
2959 assign_zero
= XCNEW (gfc_code
);
2960 assign_zero
->op
= EXEC_ASSIGN
;
2961 assign_zero
->loc
= co
->loc
;
2962 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2963 assign_zero
->expr2
= zero_e
;
2965 /* Handle the reallocation, if needed. */
2966 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2968 gfc_code
*lhs_alloc
;
2970 /* Only need to check a single dimension for the A2B2 case for
2971 bounds checking, the rest will be allocated. */
2973 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2978 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2979 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2980 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2981 "in MATMUL intrinsic: Is %ld, should be %ld");
2982 *next_code_point
= test
;
2983 next_code_point
= &test
->next
;
2987 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
2989 *next_code_point
= lhs_alloc
;
2990 next_code_point
= &lhs_alloc
->next
;
2993 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2996 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
2998 if (m_case
== A2B2
|| m_case
== A2B1
)
3000 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3001 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3002 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3003 "in MATMUL intrinsic: Is %ld, should be %ld");
3004 *next_code_point
= test
;
3005 next_code_point
= &test
->next
;
3007 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3008 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3011 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3012 "MATMUL intrinsic for dimension 1: "
3013 "is %ld, should be %ld");
3014 else if (m_case
== A2B1
)
3015 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3016 "MATMUL intrinsic: "
3017 "is %ld, should be %ld");
3020 *next_code_point
= test
;
3021 next_code_point
= &test
->next
;
3023 else if (m_case
== A1B2
)
3025 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3026 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3027 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3028 "in MATMUL intrinsic: Is %ld, should be %ld");
3029 *next_code_point
= test
;
3030 next_code_point
= &test
->next
;
3032 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3033 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3035 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3036 "MATMUL intrinsic: "
3037 "is %ld, should be %ld");
3039 *next_code_point
= test
;
3040 next_code_point
= &test
->next
;
3045 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3046 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3047 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3048 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3050 *next_code_point
= test
;
3051 next_code_point
= &test
->next
;
3054 if (m_case
== A2B2T
)
3056 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3057 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3058 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3059 "MATMUL intrinsic for dimension 1: "
3060 "is %ld, should be %ld");
3062 *next_code_point
= test
;
3063 next_code_point
= &test
->next
;
3065 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3066 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3067 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3068 "MATMUL intrinsic for dimension 2: "
3069 "is %ld, should be %ld");
3070 *next_code_point
= test
;
3071 next_code_point
= &test
->next
;
3073 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3074 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3076 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3077 "MATMUL intrnisic for dimension 2: "
3078 "is %ld, should be %ld");
3079 *next_code_point
= test
;
3080 next_code_point
= &test
->next
;
3085 *next_code_point
= assign_zero
;
3087 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3089 assign_matmul
= XCNEW (gfc_code
);
3090 assign_matmul
->op
= EXEC_ASSIGN
;
3091 assign_matmul
->loc
= co
->loc
;
3093 /* Get the bounds for the loops, create them and create the scalarized
3099 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3101 u1
= get_size_m1 (matrix_b
, 2);
3102 u2
= get_size_m1 (matrix_a
, 2);
3103 u3
= get_size_m1 (matrix_a
, 1);
3105 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3106 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3107 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3109 do_1
->block
->next
= do_2
;
3110 do_2
->block
->next
= do_3
;
3111 do_3
->block
->next
= assign_matmul
;
3113 var_1
= do_1
->ext
.iterator
->var
;
3114 var_2
= do_2
->ext
.iterator
->var
;
3115 var_3
= do_3
->ext
.iterator
->var
;
3119 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3123 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3127 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3132 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3134 u1
= get_size_m1 (matrix_b
, 1);
3135 u2
= get_size_m1 (matrix_a
, 2);
3136 u3
= get_size_m1 (matrix_a
, 1);
3138 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3139 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3140 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3142 do_1
->block
->next
= do_2
;
3143 do_2
->block
->next
= do_3
;
3144 do_3
->block
->next
= assign_matmul
;
3146 var_1
= do_1
->ext
.iterator
->var
;
3147 var_2
= do_2
->ext
.iterator
->var
;
3148 var_3
= do_3
->ext
.iterator
->var
;
3152 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3156 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3160 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3165 u1
= get_size_m1 (matrix_b
, 1);
3166 u2
= get_size_m1 (matrix_a
, 1);
3168 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3169 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3171 do_1
->block
->next
= do_2
;
3172 do_2
->block
->next
= assign_matmul
;
3174 var_1
= do_1
->ext
.iterator
->var
;
3175 var_2
= do_2
->ext
.iterator
->var
;
3178 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3182 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3185 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3190 u1
= get_size_m1 (matrix_b
, 2);
3191 u2
= get_size_m1 (matrix_a
, 1);
3193 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3194 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3196 do_1
->block
->next
= do_2
;
3197 do_2
->block
->next
= assign_matmul
;
3199 var_1
= do_1
->ext
.iterator
->var
;
3200 var_2
= do_2
->ext
.iterator
->var
;
3203 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3206 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3210 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3219 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3220 matrix_a
->where
, 1, ascalar
);
3223 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3224 matrix_b
->where
, 1, bscalar
);
3226 /* First loop comes after the zero assignment. */
3227 assign_zero
->next
= do_1
;
3229 /* Build the assignment expression in the loop. */
3230 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3232 mult
= get_operand (op_times
, ascalar
, bscalar
);
3233 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3235 /* If we don't want to keep the original statement around in
3236 the else branch, we can free it. */
3238 if (if_limit
== NULL
)
3239 gfc_free_statements(co
);
3243 gfc_free_expr (zero
);
3248 #define WALK_SUBEXPR(NODE) \
3251 result = gfc_expr_walker (&(NODE), exprfn, data); \
3256 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3258 /* Walk expression *E, calling EXPRFN on each expression in it. */
3261 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3265 int walk_subtrees
= 1;
3266 gfc_actual_arglist
*a
;
3270 int result
= exprfn (e
, &walk_subtrees
, data
);
3274 switch ((*e
)->expr_type
)
3277 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3278 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3281 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3282 WALK_SUBEXPR (a
->expr
);
3286 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3287 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3288 WALK_SUBEXPR (a
->expr
);
3291 case EXPR_STRUCTURE
:
3293 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3294 c
= gfc_constructor_next (c
))
3296 if (c
->iterator
== NULL
)
3297 WALK_SUBEXPR (c
->expr
);
3301 WALK_SUBEXPR (c
->expr
);
3303 WALK_SUBEXPR (c
->iterator
->var
);
3304 WALK_SUBEXPR (c
->iterator
->start
);
3305 WALK_SUBEXPR (c
->iterator
->end
);
3306 WALK_SUBEXPR (c
->iterator
->step
);
3310 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3313 /* Fall through to the variable case in order to walk the
3316 case EXPR_SUBSTRING
:
3318 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3327 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3329 for (i
=0; i
< ar
->dimen
; i
++)
3331 WALK_SUBEXPR (ar
->start
[i
]);
3332 WALK_SUBEXPR (ar
->end
[i
]);
3333 WALK_SUBEXPR (ar
->stride
[i
]);
3340 WALK_SUBEXPR (r
->u
.ss
.start
);
3341 WALK_SUBEXPR (r
->u
.ss
.end
);
3357 #define WALK_SUBCODE(NODE) \
3360 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3366 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3367 on each expression in it. If any of the hooks returns non-zero, that
3368 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3369 no subcodes or subexpressions are traversed. */
3372 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3375 for (; *c
; c
= &(*c
)->next
)
3377 int walk_subtrees
= 1;
3378 int result
= codefn (c
, &walk_subtrees
, data
);
3385 gfc_actual_arglist
*a
;
3387 gfc_association_list
*alist
;
3388 bool saved_in_omp_workshare
;
3389 bool saved_in_where
;
3391 /* There might be statement insertions before the current code,
3392 which must not affect the expression walker. */
3395 saved_in_omp_workshare
= in_omp_workshare
;
3396 saved_in_where
= in_where
;
3402 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3403 if (co
->ext
.block
.assoc
)
3405 bool saved_in_assoc_list
= in_assoc_list
;
3407 in_assoc_list
= true;
3408 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3409 WALK_SUBEXPR (alist
->target
);
3411 in_assoc_list
= saved_in_assoc_list
;
3418 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3419 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3420 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3421 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3429 case EXEC_ASSIGN_CALL
:
3430 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3431 WALK_SUBEXPR (a
->expr
);
3435 WALK_SUBEXPR (co
->expr1
);
3436 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3437 WALK_SUBEXPR (a
->expr
);
3441 WALK_SUBEXPR (co
->expr1
);
3442 for (b
= co
->block
; b
; b
= b
->block
)
3445 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3447 WALK_SUBEXPR (cp
->low
);
3448 WALK_SUBEXPR (cp
->high
);
3450 WALK_SUBCODE (b
->next
);
3455 case EXEC_DEALLOCATE
:
3458 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3459 WALK_SUBEXPR (a
->expr
);
3464 case EXEC_DO_CONCURRENT
:
3466 gfc_forall_iterator
*fa
;
3467 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3469 WALK_SUBEXPR (fa
->var
);
3470 WALK_SUBEXPR (fa
->start
);
3471 WALK_SUBEXPR (fa
->end
);
3472 WALK_SUBEXPR (fa
->stride
);
3474 if (co
->op
== EXEC_FORALL
)
3480 WALK_SUBEXPR (co
->ext
.open
->unit
);
3481 WALK_SUBEXPR (co
->ext
.open
->file
);
3482 WALK_SUBEXPR (co
->ext
.open
->status
);
3483 WALK_SUBEXPR (co
->ext
.open
->access
);
3484 WALK_SUBEXPR (co
->ext
.open
->form
);
3485 WALK_SUBEXPR (co
->ext
.open
->recl
);
3486 WALK_SUBEXPR (co
->ext
.open
->blank
);
3487 WALK_SUBEXPR (co
->ext
.open
->position
);
3488 WALK_SUBEXPR (co
->ext
.open
->action
);
3489 WALK_SUBEXPR (co
->ext
.open
->delim
);
3490 WALK_SUBEXPR (co
->ext
.open
->pad
);
3491 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3492 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3493 WALK_SUBEXPR (co
->ext
.open
->convert
);
3494 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3495 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3496 WALK_SUBEXPR (co
->ext
.open
->round
);
3497 WALK_SUBEXPR (co
->ext
.open
->sign
);
3498 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3499 WALK_SUBEXPR (co
->ext
.open
->id
);
3500 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3504 WALK_SUBEXPR (co
->ext
.close
->unit
);
3505 WALK_SUBEXPR (co
->ext
.close
->status
);
3506 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3507 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3510 case EXEC_BACKSPACE
:
3514 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3515 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3516 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3520 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3521 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3522 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3523 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3524 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3525 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3526 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3527 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3528 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3529 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3530 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3531 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3532 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3533 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3534 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3535 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3536 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3537 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3538 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3539 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3540 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3541 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3542 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3543 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3544 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3545 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3546 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3547 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3548 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3549 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3550 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3551 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3552 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3553 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3554 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3555 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3559 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3560 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3561 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3562 WALK_SUBEXPR (co
->ext
.wait
->id
);
3567 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3568 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3569 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3570 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3571 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3572 WALK_SUBEXPR (co
->ext
.dt
->size
);
3573 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3574 WALK_SUBEXPR (co
->ext
.dt
->id
);
3575 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3576 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3577 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3578 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3579 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3580 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3581 WALK_SUBEXPR (co
->ext
.dt
->round
);
3582 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3583 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3586 case EXEC_OMP_PARALLEL
:
3587 case EXEC_OMP_PARALLEL_DO
:
3588 case EXEC_OMP_PARALLEL_DO_SIMD
:
3589 case EXEC_OMP_PARALLEL_SECTIONS
:
3591 in_omp_workshare
= false;
3593 /* This goto serves as a shortcut to avoid code
3594 duplication or a larger if or switch statement. */
3595 goto check_omp_clauses
;
3597 case EXEC_OMP_WORKSHARE
:
3598 case EXEC_OMP_PARALLEL_WORKSHARE
:
3600 in_omp_workshare
= true;
3604 case EXEC_OMP_DISTRIBUTE
:
3605 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3606 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3607 case EXEC_OMP_DISTRIBUTE_SIMD
:
3609 case EXEC_OMP_DO_SIMD
:
3610 case EXEC_OMP_SECTIONS
:
3611 case EXEC_OMP_SINGLE
:
3612 case EXEC_OMP_END_SINGLE
:
3614 case EXEC_OMP_TARGET
:
3615 case EXEC_OMP_TARGET_DATA
:
3616 case EXEC_OMP_TARGET_TEAMS
:
3617 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3618 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3619 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3620 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3621 case EXEC_OMP_TARGET_UPDATE
:
3623 case EXEC_OMP_TEAMS
:
3624 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3625 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3626 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3627 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3629 /* Come to this label only from the
3630 EXEC_OMP_PARALLEL_* cases above. */
3634 if (co
->ext
.omp_clauses
)
3636 gfc_omp_namelist
*n
;
3637 static int list_types
[]
3638 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3639 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3641 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3642 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3643 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3644 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3645 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3646 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3647 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3648 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3649 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3650 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3652 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3654 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3656 WALK_SUBEXPR (n
->expr
);
3663 WALK_SUBEXPR (co
->expr1
);
3664 WALK_SUBEXPR (co
->expr2
);
3665 WALK_SUBEXPR (co
->expr3
);
3666 WALK_SUBEXPR (co
->expr4
);
3667 for (b
= co
->block
; b
; b
= b
->block
)
3669 WALK_SUBEXPR (b
->expr1
);
3670 WALK_SUBEXPR (b
->expr2
);
3671 WALK_SUBCODE (b
->next
);
3674 if (co
->op
== EXEC_FORALL
)
3677 if (co
->op
== EXEC_DO
)
3680 in_omp_workshare
= saved_in_omp_workshare
;
3681 in_where
= saved_in_where
;