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 ();
130 if (flag_frontend_optimize
)
132 optimize_namespace (ns
);
133 optimize_reduction (ns
);
134 if (flag_dump_fortran_optimized
)
135 gfc_dump_parse_tree (ns
, stdout
);
137 expr_array
.release ();
140 gfc_get_errors (&w
, &e
);
144 if (flag_realloc_lhs
)
145 realloc_strings (ns
);
148 /* Callback for each gfc_code node invoked from check_realloc_strings.
149 For an allocatable LHS string which also appears as a variable on
161 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
162 void *data ATTRIBUTE_UNUSED
)
164 gfc_expr
*expr1
, *expr2
;
168 if (co
->op
!= EXEC_ASSIGN
)
172 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
173 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
176 expr2
= gfc_discard_nops (co
->expr2
);
177 if (expr2
->expr_type
!= EXPR_VARIABLE
)
180 if (!gfc_check_dependency (expr1
, expr2
, true))
183 /* gfc_check_dependency doesn't always pick up identical expressions.
184 However, eliminating the above sends the compiler into an infinite
185 loop on valid expressions. Without this check, the gimplifier emits
186 an ICE for a = a, where a is deferred character length. */
187 if (!gfc_dep_compare_expr (expr1
, expr2
))
191 inserted_block
= NULL
;
192 changed_statement
= NULL
;
193 n
= create_var (expr2
, "trim");
198 /* Callback for each gfc_code node invoked through gfc_code_walker
199 from optimize_namespace. */
202 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
203 void *data ATTRIBUTE_UNUSED
)
210 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
211 || op
== EXEC_CALL_PPC
)
217 inserted_block
= NULL
;
218 changed_statement
= NULL
;
220 if (op
== EXEC_ASSIGN
)
221 optimize_assignment (*c
);
225 /* Callback for each gfc_expr node invoked through gfc_code_walker
226 from optimize_namespace. */
229 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
230 void *data ATTRIBUTE_UNUSED
)
234 if ((*e
)->expr_type
== EXPR_FUNCTION
)
237 function_expr
= true;
240 function_expr
= false;
242 if (optimize_trim (*e
))
243 gfc_simplify_expr (*e
, 0);
245 if (optimize_lexical_comparison (*e
))
246 gfc_simplify_expr (*e
, 0);
248 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
249 gfc_simplify_expr (*e
, 0);
251 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
252 switch ((*e
)->value
.function
.isym
->id
)
254 case GFC_ISYM_MINLOC
:
255 case GFC_ISYM_MAXLOC
:
256 optimize_minmaxloc (e
);
268 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
269 function is a scalar, just copy it; otherwise returns the new element, the
270 old one can be freed. */
273 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
275 gfc_expr
*fcn
, *e
= c
->expr
;
277 fcn
= gfc_copy_expr (e
);
280 gfc_constructor_base newbase
;
282 gfc_constructor
*new_c
;
285 new_expr
= gfc_get_expr ();
286 new_expr
->expr_type
= EXPR_ARRAY
;
287 new_expr
->ts
= e
->ts
;
288 new_expr
->where
= e
->where
;
290 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
291 new_c
->iterator
= c
->iterator
;
292 new_expr
->value
.constructor
= newbase
;
300 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
302 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
303 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
304 fn
->value
.function
.isym
->name
,
305 fn
->where
, 3, fcn
, NULL
, NULL
);
306 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
307 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
308 fn
->value
.function
.isym
->name
,
309 fn
->where
, 2, fcn
, NULL
);
311 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
313 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
319 /* Callback function for optimzation of reductions to scalars. Transform ANY
320 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
321 correspondingly. Handly only the simple cases without MASK and DIM. */
324 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
325 void *data ATTRIBUTE_UNUSED
)
330 gfc_actual_arglist
*a
;
331 gfc_actual_arglist
*dim
;
333 gfc_expr
*res
, *new_expr
;
334 gfc_actual_arglist
*mask
;
338 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
339 || fn
->value
.function
.isym
== NULL
)
342 id
= fn
->value
.function
.isym
->id
;
344 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
345 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
348 a
= fn
->value
.function
.actual
;
350 /* Don't handle MASK or DIM. */
354 if (dim
->expr
!= NULL
)
357 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
360 if ( mask
->expr
!= NULL
)
366 if (arg
->expr_type
!= EXPR_ARRAY
)
375 case GFC_ISYM_PRODUCT
:
376 op
= INTRINSIC_TIMES
;
391 c
= gfc_constructor_first (arg
->value
.constructor
);
393 /* Don't do any simplififcation if we have
394 - no element in the constructor or
395 - only have a single element in the array which contains an
401 res
= copy_walk_reduction_arg (c
, fn
);
403 c
= gfc_constructor_next (c
);
406 new_expr
= gfc_get_expr ();
407 new_expr
->ts
= fn
->ts
;
408 new_expr
->expr_type
= EXPR_OP
;
409 new_expr
->rank
= fn
->rank
;
410 new_expr
->where
= fn
->where
;
411 new_expr
->value
.op
.op
= op
;
412 new_expr
->value
.op
.op1
= res
;
413 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
415 c
= gfc_constructor_next (c
);
418 gfc_simplify_expr (res
, 0);
425 /* Callback function for common function elimination, called from cfe_expr_0.
426 Put all eligible function expressions into expr_array. */
429 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
430 void *data ATTRIBUTE_UNUSED
)
433 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
436 /* We don't do character functions with unknown charlens. */
437 if ((*e
)->ts
.type
== BT_CHARACTER
438 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
439 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
442 /* We don't do function elimination within FORALL statements, it can
443 lead to wrong-code in certain circumstances. */
445 if (forall_level
> 0)
448 /* Function elimination inside an iterator could lead to functions which
449 depend on iterator variables being moved outside. FIXME: We should check
450 if the functions do indeed depend on the iterator variable. */
452 if (iterator_level
> 0)
455 /* If we don't know the shape at compile time, we create an allocatable
456 temporary variable to hold the intermediate result, but only if
457 allocation on assignment is active. */
459 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
462 /* Skip the test for pure functions if -faggressive-function-elimination
464 if ((*e
)->value
.function
.esym
)
466 /* Don't create an array temporary for elemental functions. */
467 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
470 /* Only eliminate potentially impure functions if the
471 user specifically requested it. */
472 if (!flag_aggressive_function_elimination
473 && !(*e
)->value
.function
.esym
->attr
.pure
474 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
478 if ((*e
)->value
.function
.isym
)
480 /* Conversions are handled on the fly by the middle end,
481 transpose during trans-* stages and TRANSFER by the middle end. */
482 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
483 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
484 || gfc_inline_intrinsic_function_p (*e
))
487 /* Don't create an array temporary for elemental functions,
488 as this would be wasteful of memory.
489 FIXME: Create a scalar temporary during scalarization. */
490 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
493 if (!(*e
)->value
.function
.isym
->pure
)
497 expr_array
.safe_push (e
);
501 /* Auxiliary function to check if an expression is a temporary created by
505 is_fe_temp (gfc_expr
*e
)
507 if (e
->expr_type
!= EXPR_VARIABLE
)
510 return e
->symtree
->n
.sym
->attr
.fe_temp
;
513 /* Determine the length of a string, if it can be evaluated as a constant
514 expression. Return a newly allocated gfc_expr or NULL on failure.
515 If the user specified a substring which is potentially longer than
516 the string itself, the string will be padded with spaces, which
520 constant_string_length (gfc_expr
*e
)
530 length
= e
->ts
.u
.cl
->length
;
531 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
532 return gfc_copy_expr(length
);
535 /* Return length of substring, if constant. */
536 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
538 if (ref
->type
== REF_SUBSTRING
539 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
541 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
544 mpz_add_ui (res
->value
.integer
, value
, 1);
550 /* Return length of char symbol, if constant. */
552 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
553 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
554 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
560 /* Insert a block at the current position unless it has already
561 been inserted; in this case use the one already there. */
563 static gfc_namespace
*
568 /* If the block hasn't already been created, do so. */
569 if (inserted_block
== NULL
)
571 inserted_block
= XCNEW (gfc_code
);
572 inserted_block
->op
= EXEC_BLOCK
;
573 inserted_block
->loc
= (*current_code
)->loc
;
574 ns
= gfc_build_block_ns (current_ns
);
575 inserted_block
->ext
.block
.ns
= ns
;
576 inserted_block
->ext
.block
.assoc
= NULL
;
578 ns
->code
= *current_code
;
580 /* If the statement has a label, make sure it is transferred to
581 the newly created block. */
583 if ((*current_code
)->here
)
585 inserted_block
->here
= (*current_code
)->here
;
586 (*current_code
)->here
= NULL
;
589 inserted_block
->next
= (*current_code
)->next
;
590 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
591 (*current_code
)->next
= NULL
;
592 /* Insert the BLOCK at the right position. */
593 *current_code
= inserted_block
;
594 ns
->parent
= current_ns
;
597 ns
= inserted_block
->ext
.block
.ns
;
602 /* Returns a new expression (a variable) to be used in place of the old one,
603 with an optional assignment statement before the current statement to set
604 the value of the variable. Creates a new BLOCK for the statement if that
605 hasn't already been done and puts the statement, plus the newly created
606 variables, in that block. Special cases: If the expression is constant or
607 a temporary which has already been created, just copy it. */
610 create_var (gfc_expr
* e
, const char *vname
)
612 char name
[GFC_MAX_SYMBOL_LEN
+1];
613 gfc_symtree
*symtree
;
620 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
621 return gfc_copy_expr (e
);
623 ns
= insert_block ();
626 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
628 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
630 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
633 symbol
= symtree
->n
.sym
;
638 symbol
->as
= gfc_get_array_spec ();
639 symbol
->as
->rank
= e
->rank
;
641 if (e
->shape
== NULL
)
643 /* We don't know the shape at compile time, so we use an
645 symbol
->as
->type
= AS_DEFERRED
;
646 symbol
->attr
.allocatable
= 1;
650 symbol
->as
->type
= AS_EXPLICIT
;
651 /* Copy the shape. */
652 for (i
=0; i
<e
->rank
; i
++)
656 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
658 mpz_set_si (p
->value
.integer
, 1);
659 symbol
->as
->lower
[i
] = p
;
661 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
663 mpz_set (q
->value
.integer
, e
->shape
[i
]);
664 symbol
->as
->upper
[i
] = q
;
669 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
673 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
674 length
= constant_string_length (e
);
676 symbol
->ts
.u
.cl
->length
= length
;
678 symbol
->attr
.allocatable
= 1;
681 symbol
->attr
.flavor
= FL_VARIABLE
;
682 symbol
->attr
.referenced
= 1;
683 symbol
->attr
.dimension
= e
->rank
> 0;
684 symbol
->attr
.fe_temp
= 1;
685 gfc_commit_symbol (symbol
);
687 result
= gfc_get_expr ();
688 result
->expr_type
= EXPR_VARIABLE
;
690 result
->rank
= e
->rank
;
691 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
692 result
->symtree
= symtree
;
693 result
->where
= e
->where
;
696 result
->ref
= gfc_get_ref ();
697 result
->ref
->type
= REF_ARRAY
;
698 result
->ref
->u
.ar
.type
= AR_FULL
;
699 result
->ref
->u
.ar
.where
= e
->where
;
700 result
->ref
->u
.ar
.dimen
= e
->rank
;
701 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
702 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
703 if (warn_array_temporaries
)
704 gfc_warning (OPT_Warray_temporaries
,
705 "Creating array temporary at %L", &(e
->where
));
708 /* Generate the new assignment. */
709 n
= XCNEW (gfc_code
);
711 n
->loc
= (*current_code
)->loc
;
712 n
->next
= *changed_statement
;
713 n
->expr1
= gfc_copy_expr (result
);
715 *changed_statement
= n
;
721 /* Warn about function elimination. */
724 do_warn_function_elimination (gfc_expr
*e
)
726 if (e
->expr_type
!= EXPR_FUNCTION
)
728 if (e
->value
.function
.esym
)
729 gfc_warning (0, "Removing call to function %qs at %L",
730 e
->value
.function
.esym
->name
, &(e
->where
));
731 else if (e
->value
.function
.isym
)
732 gfc_warning (0, "Removing call to function %qs at %L",
733 e
->value
.function
.isym
->name
, &(e
->where
));
735 /* Callback function for the code walker for doing common function
736 elimination. This builds up the list of functions in the expression
737 and goes through them to detect duplicates, which it then replaces
741 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
742 void *data ATTRIBUTE_UNUSED
)
748 /* Don't do this optimization within OMP workshare or ASSOC lists. */
750 if (in_omp_workshare
|| in_assoc_list
)
756 expr_array
.release ();
758 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
760 /* Walk through all the functions. */
762 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
764 /* Skip if the function has been replaced by a variable already. */
765 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
772 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
775 newvar
= create_var (*ei
, "fcn");
777 if (warn_function_elimination
)
778 do_warn_function_elimination (*ej
);
781 *ej
= gfc_copy_expr (newvar
);
788 /* We did all the necessary walking in this function. */
793 /* Callback function for common function elimination, called from
794 gfc_code_walker. This keeps track of the current code, in order
795 to insert statements as needed. */
798 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
801 inserted_block
= NULL
;
802 changed_statement
= NULL
;
804 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
805 and allocation on assigment are prohibited inside WHERE, and finally
806 masking an expression would lead to wrong-code when replacing
809 b = sum(foo(a) + foo(a))
820 if ((*c
)->op
== EXEC_WHERE
)
830 /* Dummy function for expression call back, for use when we
831 really don't want to do any walking. */
834 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
835 void *data ATTRIBUTE_UNUSED
)
841 /* Dummy function for code callback, for use when we really
842 don't want to do anything. */
844 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
845 int *walk_subtrees ATTRIBUTE_UNUSED
,
846 void *data ATTRIBUTE_UNUSED
)
851 /* Code callback function for converting
858 This is because common function elimination would otherwise place the
859 temporary variables outside the loop. */
862 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
863 void *data ATTRIBUTE_UNUSED
)
866 gfc_code
*c_if1
, *c_if2
, *c_exit
;
868 gfc_expr
*e_not
, *e_cond
;
870 if (co
->op
!= EXEC_DO_WHILE
)
873 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
878 /* Generate the condition of the if statement, which is .not. the original
880 e_not
= gfc_get_expr ();
881 e_not
->ts
= e_cond
->ts
;
882 e_not
->where
= e_cond
->where
;
883 e_not
->expr_type
= EXPR_OP
;
884 e_not
->value
.op
.op
= INTRINSIC_NOT
;
885 e_not
->value
.op
.op1
= e_cond
;
887 /* Generate the EXIT statement. */
888 c_exit
= XCNEW (gfc_code
);
889 c_exit
->op
= EXEC_EXIT
;
890 c_exit
->ext
.which_construct
= co
;
891 c_exit
->loc
= co
->loc
;
893 /* Generate the IF statement. */
894 c_if2
= XCNEW (gfc_code
);
896 c_if2
->expr1
= e_not
;
897 c_if2
->next
= c_exit
;
898 c_if2
->loc
= co
->loc
;
900 /* ... plus the one to chain it to. */
901 c_if1
= XCNEW (gfc_code
);
903 c_if1
->block
= c_if2
;
904 c_if1
->loc
= co
->loc
;
906 /* Make the DO WHILE loop into a DO block by replacing the condition
907 with a true constant. */
908 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
910 /* Hang the generated if statement into the loop body. */
912 loopblock
= co
->block
->next
;
913 co
->block
->next
= c_if1
;
914 c_if1
->next
= loopblock
;
919 /* Code callback function for converting
932 because otherwise common function elimination would place the BLOCKs
933 into the wrong place. */
936 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
937 void *data ATTRIBUTE_UNUSED
)
940 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
942 if (co
->op
!= EXEC_IF
)
945 /* This loop starts out with the first ELSE statement. */
946 else_stmt
= co
->block
->block
;
948 while (else_stmt
!= NULL
)
952 /* If there is no condition, we're done. */
953 if (else_stmt
->expr1
== NULL
)
956 next_else
= else_stmt
->block
;
958 /* Generate the new IF statement. */
959 c_if2
= XCNEW (gfc_code
);
961 c_if2
->expr1
= else_stmt
->expr1
;
962 c_if2
->next
= else_stmt
->next
;
963 c_if2
->loc
= else_stmt
->loc
;
964 c_if2
->block
= next_else
;
966 /* ... plus the one to chain it to. */
967 c_if1
= XCNEW (gfc_code
);
969 c_if1
->block
= c_if2
;
970 c_if1
->loc
= else_stmt
->loc
;
972 /* Insert the new IF after the ELSE. */
973 else_stmt
->expr1
= NULL
;
974 else_stmt
->next
= c_if1
;
975 else_stmt
->block
= NULL
;
977 else_stmt
= next_else
;
979 /* Don't walk subtrees. */
983 /* Optimize a namespace, including all contained namespaces. */
986 optimize_namespace (gfc_namespace
*ns
)
988 gfc_namespace
*saved_ns
= gfc_current_ns
;
993 in_assoc_list
= false;
994 in_omp_workshare
= false;
996 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
997 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
998 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
999 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1000 if (flag_inline_matmul_limit
!= 0)
1001 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1004 /* BLOCKs are handled in the expression walker below. */
1005 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1007 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1008 optimize_namespace (ns
);
1010 gfc_current_ns
= saved_ns
;
1013 /* Handle dependencies for allocatable strings which potentially redefine
1014 themselves in an assignment. */
1017 realloc_strings (gfc_namespace
*ns
)
1020 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1022 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1024 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1025 realloc_strings (ns
);
1031 optimize_reduction (gfc_namespace
*ns
)
1034 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1035 callback_reduction
, NULL
);
1037 /* BLOCKs are handled in the expression walker below. */
1038 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1040 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1041 optimize_reduction (ns
);
1045 /* Replace code like
1048 a = matmul(b,c) ; a = a + d
1049 where the array function is not elemental and not allocatable
1050 and does not depend on the left-hand side.
1054 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1059 if (e
->expr_type
== EXPR_OP
)
1061 switch (e
->value
.op
.op
)
1063 /* Unary operators and exponentiation: Only look at a single
1066 case INTRINSIC_UPLUS
:
1067 case INTRINSIC_UMINUS
:
1068 case INTRINSIC_PARENTHESES
:
1069 case INTRINSIC_POWER
:
1070 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1074 case INTRINSIC_CONCAT
:
1075 /* Do not do string concatenations. */
1079 /* Binary operators. */
1080 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1083 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1089 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1090 && ! (e
->value
.function
.esym
1091 && (e
->value
.function
.esym
->attr
.elemental
1092 || e
->value
.function
.esym
->attr
.allocatable
1093 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1094 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1095 && ! (e
->value
.function
.isym
1096 && (e
->value
.function
.isym
->elemental
1097 || e
->ts
.type
!= c
->expr1
->ts
.type
1098 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1099 && ! gfc_inline_intrinsic_function_p (e
))
1105 /* Insert a new assignment statement after the current one. */
1106 n
= XCNEW (gfc_code
);
1107 n
->op
= EXEC_ASSIGN
;
1112 n
->expr1
= gfc_copy_expr (c
->expr1
);
1113 n
->expr2
= c
->expr2
;
1114 new_expr
= gfc_copy_expr (c
->expr1
);
1122 /* Nothing to optimize. */
1126 /* Remove unneeded TRIMs at the end of expressions. */
1129 remove_trim (gfc_expr
*rhs
)
1135 /* Check for a // b // trim(c). Looping is probably not
1136 necessary because the parser usually generates
1137 (// (// a b ) trim(c) ) , but better safe than sorry. */
1139 while (rhs
->expr_type
== EXPR_OP
1140 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1141 rhs
= rhs
->value
.op
.op2
;
1143 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1144 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1146 strip_function_call (rhs
);
1147 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1155 /* Optimizations for an assignment. */
1158 optimize_assignment (gfc_code
* c
)
1160 gfc_expr
*lhs
, *rhs
;
1165 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1167 /* Optimize a = trim(b) to a = b. */
1170 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1171 if (is_empty_string (rhs
))
1172 rhs
->value
.character
.length
= 0;
1175 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1176 optimize_binop_array_assignment (c
, &rhs
, false);
1180 /* Remove an unneeded function call, modifying the expression.
1181 This replaces the function call with the value of its
1182 first argument. The rest of the argument list is freed. */
1185 strip_function_call (gfc_expr
*e
)
1188 gfc_actual_arglist
*a
;
1190 a
= e
->value
.function
.actual
;
1192 /* We should have at least one argument. */
1193 gcc_assert (a
->expr
!= NULL
);
1197 /* Free the remaining arglist, if any. */
1199 gfc_free_actual_arglist (a
->next
);
1201 /* Graft the argument expression onto the original function. */
1207 /* Optimization of lexical comparison functions. */
1210 optimize_lexical_comparison (gfc_expr
*e
)
1212 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1215 switch (e
->value
.function
.isym
->id
)
1218 return optimize_comparison (e
, INTRINSIC_LE
);
1221 return optimize_comparison (e
, INTRINSIC_GE
);
1224 return optimize_comparison (e
, INTRINSIC_GT
);
1227 return optimize_comparison (e
, INTRINSIC_LT
);
1235 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1236 do CHARACTER because of possible pessimization involving character
1240 combine_array_constructor (gfc_expr
*e
)
1243 gfc_expr
*op1
, *op2
;
1246 gfc_constructor
*c
, *new_c
;
1247 gfc_constructor_base oldbase
, newbase
;
1250 /* Array constructors have rank one. */
1254 /* Don't try to combine association lists, this makes no sense
1255 and leads to an ICE. */
1259 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1260 if (forall_level
> 0)
1263 /* Inside an iterator, things can get hairy; we are likely to create
1264 an invalid temporary variable. */
1265 if (iterator_level
> 0)
1268 op1
= e
->value
.op
.op1
;
1269 op2
= e
->value
.op
.op2
;
1271 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1272 scalar_first
= false;
1273 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1275 scalar_first
= true;
1276 op1
= e
->value
.op
.op2
;
1277 op2
= e
->value
.op
.op1
;
1282 if (op2
->ts
.type
== BT_CHARACTER
)
1285 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1287 oldbase
= op1
->value
.constructor
;
1289 e
->expr_type
= EXPR_ARRAY
;
1291 for (c
= gfc_constructor_first (oldbase
); c
;
1292 c
= gfc_constructor_next (c
))
1294 new_expr
= gfc_get_expr ();
1295 new_expr
->ts
= e
->ts
;
1296 new_expr
->expr_type
= EXPR_OP
;
1297 new_expr
->rank
= c
->expr
->rank
;
1298 new_expr
->where
= c
->where
;
1299 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1303 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1304 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1308 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1309 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1312 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1313 new_c
->iterator
= c
->iterator
;
1317 gfc_free_expr (op1
);
1318 gfc_free_expr (op2
);
1319 gfc_free_expr (scalar
);
1321 e
->value
.constructor
= newbase
;
1325 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1326 2**k into ishift(1,k) */
1329 optimize_power (gfc_expr
*e
)
1331 gfc_expr
*op1
, *op2
;
1332 gfc_expr
*iand
, *ishft
;
1334 if (e
->ts
.type
!= BT_INTEGER
)
1337 op1
= e
->value
.op
.op1
;
1339 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1342 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1344 gfc_free_expr (op1
);
1346 op2
= e
->value
.op
.op2
;
1351 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1352 "_internal_iand", e
->where
, 2, op2
,
1353 gfc_get_int_expr (e
->ts
.kind
,
1356 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1357 "_internal_ishft", e
->where
, 2, iand
,
1358 gfc_get_int_expr (e
->ts
.kind
,
1361 e
->value
.op
.op
= INTRINSIC_MINUS
;
1362 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1363 e
->value
.op
.op2
= ishft
;
1366 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1368 gfc_free_expr (op1
);
1370 op2
= e
->value
.op
.op2
;
1374 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1375 "_internal_ishft", e
->where
, 2,
1376 gfc_get_int_expr (e
->ts
.kind
,
1383 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1385 op2
= e
->value
.op
.op2
;
1389 gfc_free_expr (op1
);
1390 gfc_free_expr (op2
);
1392 e
->expr_type
= EXPR_CONSTANT
;
1393 e
->value
.op
.op1
= NULL
;
1394 e
->value
.op
.op2
= NULL
;
1395 mpz_init_set_si (e
->value
.integer
, 1);
1396 /* Typespec and location are still OK. */
1403 /* Recursive optimization of operators. */
1406 optimize_op (gfc_expr
*e
)
1410 gfc_intrinsic_op op
= e
->value
.op
.op
;
1414 /* Only use new-style comparisons. */
1417 case INTRINSIC_EQ_OS
:
1421 case INTRINSIC_GE_OS
:
1425 case INTRINSIC_LE_OS
:
1429 case INTRINSIC_NE_OS
:
1433 case INTRINSIC_GT_OS
:
1437 case INTRINSIC_LT_OS
:
1453 changed
= optimize_comparison (e
, op
);
1456 /* Look at array constructors. */
1457 case INTRINSIC_PLUS
:
1458 case INTRINSIC_MINUS
:
1459 case INTRINSIC_TIMES
:
1460 case INTRINSIC_DIVIDE
:
1461 return combine_array_constructor (e
) || changed
;
1463 case INTRINSIC_POWER
:
1464 return optimize_power (e
);
1475 /* Return true if a constant string contains only blanks. */
1478 is_empty_string (gfc_expr
*e
)
1482 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1485 for (i
=0; i
< e
->value
.character
.length
; i
++)
1487 if (e
->value
.character
.string
[i
] != ' ')
1495 /* Insert a call to the intrinsic len_trim. Use a different name for
1496 the symbol tree so we don't run into trouble when the user has
1497 renamed len_trim for some reason. */
1500 get_len_trim_call (gfc_expr
*str
, int kind
)
1503 gfc_actual_arglist
*actual_arglist
, *next
;
1505 fcn
= gfc_get_expr ();
1506 fcn
->expr_type
= EXPR_FUNCTION
;
1507 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1508 actual_arglist
= gfc_get_actual_arglist ();
1509 actual_arglist
->expr
= str
;
1510 next
= gfc_get_actual_arglist ();
1511 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1512 actual_arglist
->next
= next
;
1514 fcn
->value
.function
.actual
= actual_arglist
;
1515 fcn
->where
= str
->where
;
1516 fcn
->ts
.type
= BT_INTEGER
;
1517 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1519 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1520 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1521 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1522 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1523 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1524 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1525 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1526 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1531 /* Optimize expressions for equality. */
1534 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1536 gfc_expr
*op1
, *op2
;
1540 gfc_actual_arglist
*firstarg
, *secondarg
;
1542 if (e
->expr_type
== EXPR_OP
)
1546 op1
= e
->value
.op
.op1
;
1547 op2
= e
->value
.op
.op2
;
1549 else if (e
->expr_type
== EXPR_FUNCTION
)
1551 /* One of the lexical comparison functions. */
1552 firstarg
= e
->value
.function
.actual
;
1553 secondarg
= firstarg
->next
;
1554 op1
= firstarg
->expr
;
1555 op2
= secondarg
->expr
;
1560 /* Strip off unneeded TRIM calls from string comparisons. */
1562 change
= remove_trim (op1
);
1564 if (remove_trim (op2
))
1567 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1568 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1569 handles them well). However, there are also cases that need a non-scalar
1570 argument. For example the any intrinsic. See PR 45380. */
1574 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1576 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1577 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1579 bool empty_op1
, empty_op2
;
1580 empty_op1
= is_empty_string (op1
);
1581 empty_op2
= is_empty_string (op2
);
1583 if (empty_op1
|| empty_op2
)
1589 /* This can only happen when an error for comparing
1590 characters of different kinds has already been issued. */
1591 if (empty_op1
&& empty_op2
)
1594 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1595 str
= empty_op1
? op2
: op1
;
1597 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1601 gfc_free_expr (op1
);
1603 gfc_free_expr (op2
);
1607 e
->value
.op
.op1
= fcn
;
1608 e
->value
.op
.op2
= zero
;
1613 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1615 if (flag_finite_math_only
1616 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1617 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1619 eq
= gfc_dep_compare_expr (op1
, op2
);
1622 /* Replace A // B < A // C with B < C, and A // B < C // B
1624 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1625 && op1
->expr_type
== EXPR_OP
1626 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1627 && op2
->expr_type
== EXPR_OP
1628 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1630 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1631 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1632 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1633 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1635 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1637 /* Watch out for 'A ' // x vs. 'A' // x. */
1639 if (op1_left
->expr_type
== EXPR_CONSTANT
1640 && op2_left
->expr_type
== EXPR_CONSTANT
1641 && op1_left
->value
.character
.length
1642 != op2_left
->value
.character
.length
)
1650 firstarg
->expr
= op1_right
;
1651 secondarg
->expr
= op2_right
;
1655 e
->value
.op
.op1
= op1_right
;
1656 e
->value
.op
.op2
= op2_right
;
1658 optimize_comparison (e
, op
);
1662 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1668 firstarg
->expr
= op1_left
;
1669 secondarg
->expr
= op2_left
;
1673 e
->value
.op
.op1
= op1_left
;
1674 e
->value
.op
.op2
= op2_left
;
1677 optimize_comparison (e
, op
);
1684 /* eq can only be -1, 0 or 1 at this point. */
1712 gfc_internal_error ("illegal OP in optimize_comparison");
1716 /* Replace the expression by a constant expression. The typespec
1717 and where remains the way it is. */
1720 e
->expr_type
= EXPR_CONSTANT
;
1721 e
->value
.logical
= result
;
1729 /* Optimize a trim function by replacing it with an equivalent substring
1730 involving a call to len_trim. This only works for expressions where
1731 variables are trimmed. Return true if anything was modified. */
1734 optimize_trim (gfc_expr
*e
)
1739 gfc_ref
**rr
= NULL
;
1741 /* Don't do this optimization within an argument list, because
1742 otherwise aliasing issues may occur. */
1744 if (count_arglist
!= 1)
1747 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1748 || e
->value
.function
.isym
== NULL
1749 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1752 a
= e
->value
.function
.actual
->expr
;
1754 if (a
->expr_type
!= EXPR_VARIABLE
)
1757 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1759 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1762 /* Follow all references to find the correct place to put the newly
1763 created reference. FIXME: Also handle substring references and
1764 array references. Array references cause strange regressions at
1769 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1771 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1776 strip_function_call (e
);
1781 /* Create the reference. */
1783 ref
= gfc_get_ref ();
1784 ref
->type
= REF_SUBSTRING
;
1786 /* Set the start of the reference. */
1788 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1790 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1792 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1794 /* Set the end of the reference to the call to len_trim. */
1796 ref
->u
.ss
.end
= fcn
;
1797 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1802 /* Optimize minloc(b), where b is rank 1 array, into
1803 (/ minloc(b, dim=1) /), and similarly for maxloc,
1804 as the latter forms are expanded inline. */
1807 optimize_minmaxloc (gfc_expr
**e
)
1810 gfc_actual_arglist
*a
;
1814 || fn
->value
.function
.actual
== NULL
1815 || fn
->value
.function
.actual
->expr
== NULL
1816 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1819 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1820 (*e
)->shape
= fn
->shape
;
1823 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1825 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1826 strcpy (name
, fn
->value
.function
.name
);
1827 p
= strstr (name
, "loc0");
1829 fn
->value
.function
.name
= gfc_get_string (name
);
1830 if (fn
->value
.function
.actual
->next
)
1832 a
= fn
->value
.function
.actual
->next
;
1833 gcc_assert (a
->expr
== NULL
);
1837 a
= gfc_get_actual_arglist ();
1838 fn
->value
.function
.actual
->next
= a
;
1840 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1842 mpz_set_ui (a
->expr
->value
.integer
, 1);
1845 /* Callback function for code checking that we do not pass a DO variable to an
1846 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1849 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1850 void *data ATTRIBUTE_UNUSED
)
1854 gfc_formal_arglist
*f
;
1855 gfc_actual_arglist
*a
;
1860 /* If the doloop_list grew, we have to truncate it here. */
1862 if ((unsigned) doloop_level
< doloop_list
.length())
1863 doloop_list
.truncate (doloop_level
);
1869 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1870 doloop_list
.safe_push (co
);
1872 doloop_list
.safe_push ((gfc_code
*) NULL
);
1877 if (co
->resolved_sym
== NULL
)
1880 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1882 /* Withot a formal arglist, there is only unknown INTENT,
1883 which we don't check for. */
1891 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1898 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1900 if (a
->expr
&& a
->expr
->symtree
1901 && a
->expr
->symtree
->n
.sym
== do_sym
)
1903 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1904 gfc_error_now ("Variable %qs at %L set to undefined "
1905 "value inside loop beginning at %L as "
1906 "INTENT(OUT) argument to subroutine %qs",
1907 do_sym
->name
, &a
->expr
->where
,
1908 &doloop_list
[i
]->loc
,
1909 co
->symtree
->n
.sym
->name
);
1910 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1911 gfc_error_now ("Variable %qs at %L not definable inside "
1912 "loop beginning at %L as INTENT(INOUT) "
1913 "argument to subroutine %qs",
1914 do_sym
->name
, &a
->expr
->where
,
1915 &doloop_list
[i
]->loc
,
1916 co
->symtree
->n
.sym
->name
);
1930 /* Callback function for functions checking that we do not pass a DO variable
1931 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1934 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1935 void *data ATTRIBUTE_UNUSED
)
1937 gfc_formal_arglist
*f
;
1938 gfc_actual_arglist
*a
;
1944 if (expr
->expr_type
!= EXPR_FUNCTION
)
1947 /* Intrinsic functions don't modify their arguments. */
1949 if (expr
->value
.function
.isym
)
1952 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1954 /* Without a formal arglist, there is only unknown INTENT,
1955 which we don't check for. */
1959 a
= expr
->value
.function
.actual
;
1963 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1970 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1972 if (a
->expr
&& a
->expr
->symtree
1973 && a
->expr
->symtree
->n
.sym
== do_sym
)
1975 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1976 gfc_error_now ("Variable %qs at %L set to undefined value "
1977 "inside loop beginning at %L as INTENT(OUT) "
1978 "argument to function %qs", do_sym
->name
,
1979 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1980 expr
->symtree
->n
.sym
->name
);
1981 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1982 gfc_error_now ("Variable %qs at %L not definable inside loop"
1983 " beginning at %L as INTENT(INOUT) argument to"
1984 " function %qs", do_sym
->name
,
1985 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1986 expr
->symtree
->n
.sym
->name
);
1997 doloop_warn (gfc_namespace
*ns
)
1999 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2002 /* This selction deals with inlining calls to MATMUL. */
2004 /* Auxiliary function to build and simplify an array inquiry function.
2005 dim is zero-based. */
2008 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2011 gfc_expr
*dim_arg
, *kind
;
2017 case GFC_ISYM_LBOUND
:
2018 name
= "_gfortran_lbound";
2021 case GFC_ISYM_UBOUND
:
2022 name
= "_gfortran_ubound";
2026 name
= "_gfortran_size";
2033 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2034 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2035 gfc_index_integer_kind
);
2037 ec
= gfc_copy_expr (e
);
2038 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2040 gfc_simplify_expr (fcn
, 0);
2044 /* Builds a logical expression. */
2047 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2052 ts
.type
= BT_LOGICAL
;
2053 ts
.kind
= gfc_default_logical_kind
;
2054 res
= gfc_get_expr ();
2055 res
->where
= e1
->where
;
2056 res
->expr_type
= EXPR_OP
;
2057 res
->value
.op
.op
= op
;
2058 res
->value
.op
.op1
= e1
;
2059 res
->value
.op
.op2
= e2
;
2066 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2067 compatible typespecs. */
2070 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2074 res
= gfc_get_expr ();
2076 res
->where
= e1
->where
;
2077 res
->expr_type
= EXPR_OP
;
2078 res
->value
.op
.op
= op
;
2079 res
->value
.op
.op1
= e1
;
2080 res
->value
.op
.op2
= e2
;
2081 gfc_simplify_expr (res
, 0);
2085 /* Generate the IF statement for a runtime check if we want to do inlining or
2086 not - putting in the code for both branches and putting it into the syntax
2087 tree is the caller's responsibility. For fixed array sizes, this should be
2088 removed by DCE. Only called for rank-two matrices A and B. */
2091 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2093 gfc_expr
*inline_limit
;
2094 gfc_code
*if_1
, *if_2
, *else_2
;
2095 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2099 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2101 /* Calculation is done in real to avoid integer overflow. */
2103 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2105 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2107 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2110 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2111 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2112 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2116 ts
.kind
= gfc_default_real_kind
;
2117 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2118 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2119 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2121 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2122 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2124 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2125 gfc_simplify_expr (cond
, 0);
2127 else_2
= XCNEW (gfc_code
);
2128 else_2
->op
= EXEC_IF
;
2129 else_2
->loc
= a
->where
;
2131 if_2
= XCNEW (gfc_code
);
2134 if_2
->loc
= a
->where
;
2135 if_2
->block
= else_2
;
2137 if_1
= XCNEW (gfc_code
);
2140 if_1
->loc
= a
->where
;
2146 /* Insert code to issue a runtime error if the expressions are not equal. */
2149 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2152 gfc_code
*if_1
, *if_2
;
2154 gfc_actual_arglist
*a1
, *a2
, *a3
;
2156 gcc_assert (e1
->where
.lb
);
2157 /* Build the call to runtime_error. */
2158 c
= XCNEW (gfc_code
);
2162 /* Get a null-terminated message string. */
2164 a1
= gfc_get_actual_arglist ();
2165 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2166 msg
, strlen(msg
)+1);
2169 /* Pass the value of the first expression. */
2170 a2
= gfc_get_actual_arglist ();
2171 a2
->expr
= gfc_copy_expr (e1
);
2174 /* Pass the value of the second expression. */
2175 a3
= gfc_get_actual_arglist ();
2176 a3
->expr
= gfc_copy_expr (e2
);
2179 gfc_check_fe_runtime_error (c
->ext
.actual
);
2180 gfc_resolve_fe_runtime_error (c
);
2182 if_2
= XCNEW (gfc_code
);
2184 if_2
->loc
= e1
->where
;
2187 if_1
= XCNEW (gfc_code
);
2190 if_1
->loc
= e1
->where
;
2192 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2193 gfc_simplify_expr (cond
, 0);
2199 /* Handle matrix reallocation. Caller is responsible to insert into
2202 For the two-dimensional case, build
2204 if (allocated(c)) then
2205 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2207 allocate (c(size(a,1), size(b,2)))
2210 allocate (c(size(a,1),size(b,2)))
2213 and for the other cases correspondingly.
2217 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2218 enum matrix_case m_case
)
2221 gfc_expr
*allocated
, *alloc_expr
;
2222 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2223 gfc_code
*else_alloc
;
2224 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2226 gfc_expr
*cond
, *ne1
, *ne2
;
2228 if (warn_realloc_lhs
)
2229 gfc_warning (OPT_Wrealloc_lhs
,
2230 "Code for reallocating the allocatable array at %L will "
2231 "be added", &c
->where
);
2233 alloc_expr
= gfc_copy_expr (c
);
2235 ar
= gfc_find_array_ref (alloc_expr
);
2236 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2238 /* c comes in as a full ref. Change it into a copy and make it into an
2239 element ref so it has the right form for for ALLOCATE. In the same
2240 switch statement, also generate the size comparison for the secod IF
2243 ar
->type
= AR_ELEMENT
;
2248 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2249 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2250 ne1
= build_logical_expr (INTRINSIC_NE
,
2251 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2252 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2253 ne2
= build_logical_expr (INTRINSIC_NE
,
2254 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2255 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2256 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2260 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2261 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2263 ne1
= build_logical_expr (INTRINSIC_NE
,
2264 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2265 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2266 ne2
= build_logical_expr (INTRINSIC_NE
,
2267 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2268 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2269 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2273 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2274 cond
= build_logical_expr (INTRINSIC_NE
,
2275 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2276 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2280 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2281 cond
= build_logical_expr (INTRINSIC_NE
,
2282 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2283 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2291 gfc_simplify_expr (cond
, 0);
2293 /* We need two identical allocate statements in two
2294 branches of the IF statement. */
2296 allocate1
= XCNEW (gfc_code
);
2297 allocate1
->op
= EXEC_ALLOCATE
;
2298 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2299 allocate1
->loc
= c
->where
;
2300 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2302 allocate_else
= XCNEW (gfc_code
);
2303 allocate_else
->op
= EXEC_ALLOCATE
;
2304 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2305 allocate_else
->loc
= c
->where
;
2306 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2308 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2309 "_gfortran_allocated", c
->where
,
2310 1, gfc_copy_expr (c
));
2312 deallocate
= XCNEW (gfc_code
);
2313 deallocate
->op
= EXEC_DEALLOCATE
;
2314 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2315 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2316 deallocate
->next
= allocate1
;
2317 deallocate
->loc
= c
->where
;
2319 if_size_2
= XCNEW (gfc_code
);
2320 if_size_2
->op
= EXEC_IF
;
2321 if_size_2
->expr1
= cond
;
2322 if_size_2
->loc
= c
->where
;
2323 if_size_2
->next
= deallocate
;
2325 if_size_1
= XCNEW (gfc_code
);
2326 if_size_1
->op
= EXEC_IF
;
2327 if_size_1
->block
= if_size_2
;
2328 if_size_1
->loc
= c
->where
;
2330 else_alloc
= XCNEW (gfc_code
);
2331 else_alloc
->op
= EXEC_IF
;
2332 else_alloc
->loc
= c
->where
;
2333 else_alloc
->next
= allocate_else
;
2335 if_alloc_2
= XCNEW (gfc_code
);
2336 if_alloc_2
->op
= EXEC_IF
;
2337 if_alloc_2
->expr1
= allocated
;
2338 if_alloc_2
->loc
= c
->where
;
2339 if_alloc_2
->next
= if_size_1
;
2340 if_alloc_2
->block
= else_alloc
;
2342 if_alloc_1
= XCNEW (gfc_code
);
2343 if_alloc_1
->op
= EXEC_IF
;
2344 if_alloc_1
->block
= if_alloc_2
;
2345 if_alloc_1
->loc
= c
->where
;
2350 /* Callback function for has_function_or_op. */
2353 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2354 void *data ATTRIBUTE_UNUSED
)
2359 return (*e
)->expr_type
== EXPR_FUNCTION
2360 || (*e
)->expr_type
== EXPR_OP
;
2363 /* Returns true if the expression contains a function. */
2366 has_function_or_op (gfc_expr
**e
)
2371 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2374 /* Freeze (assign to a temporary variable) a single expression. */
2377 freeze_expr (gfc_expr
**ep
)
2380 if (has_function_or_op (ep
))
2382 ne
= create_var (*ep
, "freeze");
2387 /* Go through an expression's references and assign them to temporary
2388 variables if they contain functions. This is usually done prior to
2389 front-end scalarization to avoid multiple invocations of functions. */
2392 freeze_references (gfc_expr
*e
)
2398 for (r
=e
->ref
; r
; r
=r
->next
)
2400 if (r
->type
== REF_SUBSTRING
)
2402 if (r
->u
.ss
.start
!= NULL
)
2403 freeze_expr (&r
->u
.ss
.start
);
2405 if (r
->u
.ss
.end
!= NULL
)
2406 freeze_expr (&r
->u
.ss
.end
);
2408 else if (r
->type
== REF_ARRAY
)
2417 for (i
=0; i
<ar
->dimen
; i
++)
2419 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2421 freeze_expr (&ar
->start
[i
]);
2422 freeze_expr (&ar
->end
[i
]);
2423 freeze_expr (&ar
->stride
[i
]);
2425 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2427 freeze_expr (&ar
->start
[i
]);
2433 for (i
=0; i
<ar
->dimen
; i
++)
2434 freeze_expr (&ar
->start
[i
]);
2444 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2447 convert_to_index_kind (gfc_expr
*e
)
2451 gcc_assert (e
!= NULL
);
2453 res
= gfc_copy_expr (e
);
2455 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2457 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2461 ts
.type
= BT_INTEGER
;
2462 ts
.kind
= gfc_index_integer_kind
;
2464 gfc_convert_type_warn (e
, &ts
, 2, 0);
2470 /* Function to create a DO loop including creation of the
2471 iteration variable. gfc_expr are copied.*/
2474 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2475 gfc_namespace
*ns
, char *vname
)
2478 char name
[GFC_MAX_SYMBOL_LEN
+1];
2479 gfc_symtree
*symtree
;
2484 /* Create an expression for the iteration variable. */
2486 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2488 sprintf (name
, "__var_%d_do", var_num
++);
2491 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2494 /* Create the loop variable. */
2496 symbol
= symtree
->n
.sym
;
2497 symbol
->ts
.type
= BT_INTEGER
;
2498 symbol
->ts
.kind
= gfc_index_integer_kind
;
2499 symbol
->attr
.flavor
= FL_VARIABLE
;
2500 symbol
->attr
.referenced
= 1;
2501 symbol
->attr
.dimension
= 0;
2502 symbol
->attr
.fe_temp
= 1;
2503 gfc_commit_symbol (symbol
);
2505 i
= gfc_get_expr ();
2506 i
->expr_type
= EXPR_VARIABLE
;
2510 i
->symtree
= symtree
;
2512 /* ... and the nested DO statements. */
2513 n
= XCNEW (gfc_code
);
2516 n
->ext
.iterator
= gfc_get_iterator ();
2517 n
->ext
.iterator
->var
= i
;
2518 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2519 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2521 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2523 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2526 n2
= XCNEW (gfc_code
);
2534 /* Get the upper bound of the DO loops for matmul along a dimension. This
2538 get_size_m1 (gfc_expr
*e
, int dimen
)
2543 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2545 res
= gfc_get_constant_expr (BT_INTEGER
,
2546 gfc_index_integer_kind
, &e
->where
);
2547 mpz_sub_ui (res
->value
.integer
, size
, 1);
2552 res
= get_operand (INTRINSIC_MINUS
,
2553 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2554 gfc_get_int_expr (gfc_index_integer_kind
,
2556 gfc_simplify_expr (res
, 0);
2562 /* Function to return a scalarized expression. It is assumed that indices are
2563 zero based to make generation of DO loops easier. A zero as index will
2564 access the first element along a dimension. Single element references will
2565 be skipped. A NULL as an expression will be replaced by a full reference.
2566 This assumes that the index loops have gfc_index_integer_kind, and that all
2567 references have been frozen. */
2570 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2579 e
= gfc_copy_expr(e_in
);
2583 ar
= gfc_find_array_ref (e
);
2585 /* We scalarize count_index variables, reducing the rank by count_index. */
2587 e
->rank
= rank
- count_index
;
2589 was_fullref
= ar
->type
== AR_FULL
;
2592 ar
->type
= AR_ELEMENT
;
2594 ar
->type
= AR_SECTION
;
2596 /* Loop over the indices. For each index, create the expression
2597 index * stride + lbound(e, dim). */
2600 for (i
=0; i
< ar
->dimen
; i
++)
2602 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2604 if (index
[i_index
] != NULL
)
2606 gfc_expr
*lbound
, *nindex
;
2609 loopvar
= gfc_copy_expr (index
[i_index
]);
2615 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2616 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2620 ts
.type
= BT_INTEGER
;
2621 ts
.kind
= gfc_index_integer_kind
;
2622 gfc_convert_type (tmp
, &ts
, 2);
2624 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2629 /* Calculate the lower bound of the expression. */
2632 lbound
= gfc_copy_expr (ar
->start
[i
]);
2633 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2637 ts
.type
= BT_INTEGER
;
2638 ts
.kind
= gfc_index_integer_kind
;
2639 gfc_convert_type (lbound
, &ts
, 2);
2648 lbound_e
= gfc_copy_expr (e_in
);
2650 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2651 if (ref
->type
== REF_ARRAY
2652 && (ref
->u
.ar
.type
== AR_FULL
2653 || ref
->u
.ar
.type
== AR_SECTION
))
2658 gfc_free_ref_list (ref
->next
);
2664 /* Look at full individual sections, like a(:). The first index
2665 is the lbound of a full ref. */
2671 for (j
= 0; j
< ar
->dimen
; j
++)
2673 gfc_free_expr (ar
->start
[j
]);
2674 ar
->start
[j
] = NULL
;
2675 gfc_free_expr (ar
->end
[j
]);
2677 gfc_free_expr (ar
->stride
[j
]);
2678 ar
->stride
[j
] = NULL
;
2681 /* We have to get rid of the shape, if there is one. Do
2682 so by freeing it and calling gfc_resolve to rebuild
2683 it, if necessary. */
2685 if (lbound_e
->shape
)
2686 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2688 lbound_e
->rank
= ar
->dimen
;
2689 gfc_resolve_expr (lbound_e
);
2691 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2693 gfc_free_expr (lbound_e
);
2696 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2698 gfc_free_expr (ar
->start
[i
]);
2699 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2701 gfc_free_expr (ar
->end
[i
]);
2703 gfc_free_expr (ar
->stride
[i
]);
2704 ar
->stride
[i
] = NULL
;
2705 gfc_simplify_expr (ar
->start
[i
], 0);
2707 else if (was_fullref
)
2709 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2718 /* Helper function to check for a dimen vector as subscript. */
2721 has_dimen_vector_ref (gfc_expr
*e
)
2726 ar
= gfc_find_array_ref (e
);
2728 if (ar
->type
== AR_FULL
)
2731 for (i
=0; i
<ar
->dimen
; i
++)
2732 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2738 /* If handed an expression of the form
2742 check if A can be handled by matmul and return if there is an uneven number
2743 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2744 otherwise. The caller has to check for the correct rank. */
2747 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2754 if (e
->expr_type
== EXPR_VARIABLE
)
2756 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2759 else if (e
->expr_type
== EXPR_FUNCTION
)
2761 if (e
->value
.function
.isym
== NULL
)
2764 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2766 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2767 *transpose
= !*transpose
;
2773 e
= e
->value
.function
.actual
->expr
;
2780 /* Inline assignments of the form c = matmul(a,b).
2781 Handle only the cases currently where b and c are rank-two arrays.
2783 This basically translates the code to
2789 do k=0, size(a, 2)-1
2790 do i=0, size(a, 1)-1
2791 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2792 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2793 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2794 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2803 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2804 void *data ATTRIBUTE_UNUSED
)
2807 gfc_expr
*expr1
, *expr2
;
2808 gfc_expr
*matrix_a
, *matrix_b
;
2809 gfc_actual_arglist
*a
, *b
;
2810 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2812 gfc_expr
*u1
, *u2
, *u3
;
2814 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2816 gfc_expr
*var_1
, *var_2
, *var_3
;
2819 gfc_intrinsic_op op_times
, op_plus
;
2820 enum matrix_case m_case
;
2822 gfc_code
*if_limit
= NULL
;
2823 gfc_code
**next_code_point
;
2824 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2826 if (co
->op
!= EXEC_ASSIGN
)
2832 /* For now don't do anything in OpenMP workshare, it confuses
2833 its translation, which expects only the allowed statements in there.
2834 We should figure out how to parallelize this eventually. */
2835 if (in_omp_workshare
)
2840 if (expr2
->expr_type
!= EXPR_FUNCTION
2841 || expr2
->value
.function
.isym
== NULL
2842 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2846 inserted_block
= NULL
;
2847 changed_statement
= NULL
;
2849 a
= expr2
->value
.function
.actual
;
2850 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2851 if (transpose_a
|| matrix_a
== NULL
)
2855 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2856 if (matrix_b
== NULL
)
2859 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2860 || has_dimen_vector_ref (matrix_b
))
2863 /* We do not handle data dependencies yet. */
2864 if (gfc_check_dependency (expr1
, matrix_a
, true)
2865 || gfc_check_dependency (expr1
, matrix_b
, true))
2868 if (matrix_a
->rank
== 2)
2870 if (matrix_b
->rank
== 1)
2882 /* Vector * Transpose(B) not handled yet. */
2892 ns
= insert_block ();
2894 /* Assign the type of the zero expression for initializing the resulting
2895 array, and the expression (+ and * for real, integer and complex;
2896 .and. and .or for logical. */
2898 switch(expr1
->ts
.type
)
2901 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2902 op_times
= INTRINSIC_TIMES
;
2903 op_plus
= INTRINSIC_PLUS
;
2907 op_times
= INTRINSIC_AND
;
2908 op_plus
= INTRINSIC_OR
;
2909 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2913 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2915 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2916 op_times
= INTRINSIC_TIMES
;
2917 op_plus
= INTRINSIC_PLUS
;
2921 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2923 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2924 op_times
= INTRINSIC_TIMES
;
2925 op_plus
= INTRINSIC_PLUS
;
2933 current_code
= &ns
->code
;
2935 /* Freeze the references, keeping track of how many temporary variables were
2938 freeze_references (matrix_a
);
2939 freeze_references (matrix_b
);
2940 freeze_references (expr1
);
2943 next_code_point
= current_code
;
2946 next_code_point
= &ns
->code
;
2947 for (i
=0; i
<n_vars
; i
++)
2948 next_code_point
= &(*next_code_point
)->next
;
2951 /* Take care of the inline flag. If the limit check evaluates to a
2952 constant, dead code elimination will eliminate the unneeded branch. */
2954 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2956 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2958 /* Insert the original statement into the else branch. */
2959 if_limit
->block
->block
->next
= co
;
2962 /* ... and the new ones go into the original one. */
2963 *next_code_point
= if_limit
;
2964 next_code_point
= &if_limit
->block
->next
;
2967 assign_zero
= XCNEW (gfc_code
);
2968 assign_zero
->op
= EXEC_ASSIGN
;
2969 assign_zero
->loc
= co
->loc
;
2970 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2971 assign_zero
->expr2
= zero_e
;
2973 /* Handle the reallocation, if needed. */
2974 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2976 gfc_code
*lhs_alloc
;
2978 /* Only need to check a single dimension for the A2B2 case for
2979 bounds checking, the rest will be allocated. */
2981 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2986 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2987 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2988 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2989 "in MATMUL intrinsic: Is %ld, should be %ld");
2990 *next_code_point
= test
;
2991 next_code_point
= &test
->next
;
2995 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
2997 *next_code_point
= lhs_alloc
;
2998 next_code_point
= &lhs_alloc
->next
;
3001 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3004 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3006 if (m_case
== A2B2
|| m_case
== A2B1
)
3008 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3009 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3010 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3011 "in MATMUL intrinsic: Is %ld, should be %ld");
3012 *next_code_point
= test
;
3013 next_code_point
= &test
->next
;
3015 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3016 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3019 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3020 "MATMUL intrinsic for dimension 1: "
3021 "is %ld, should be %ld");
3022 else if (m_case
== A2B1
)
3023 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3024 "MATMUL intrinsic: "
3025 "is %ld, should be %ld");
3028 *next_code_point
= test
;
3029 next_code_point
= &test
->next
;
3031 else if (m_case
== A1B2
)
3033 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3034 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3035 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3036 "in MATMUL intrinsic: Is %ld, should be %ld");
3037 *next_code_point
= test
;
3038 next_code_point
= &test
->next
;
3040 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3041 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3043 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3044 "MATMUL intrinsic: "
3045 "is %ld, should be %ld");
3047 *next_code_point
= test
;
3048 next_code_point
= &test
->next
;
3053 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3054 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3055 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3056 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3058 *next_code_point
= test
;
3059 next_code_point
= &test
->next
;
3062 if (m_case
== A2B2T
)
3064 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3065 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3066 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3067 "MATMUL intrinsic for dimension 1: "
3068 "is %ld, should be %ld");
3070 *next_code_point
= test
;
3071 next_code_point
= &test
->next
;
3073 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3074 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3075 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3076 "MATMUL intrinsic for dimension 2: "
3077 "is %ld, should be %ld");
3078 *next_code_point
= test
;
3079 next_code_point
= &test
->next
;
3081 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3082 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3084 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3085 "MATMUL intrnisic for dimension 2: "
3086 "is %ld, should be %ld");
3087 *next_code_point
= test
;
3088 next_code_point
= &test
->next
;
3093 *next_code_point
= assign_zero
;
3095 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3097 assign_matmul
= XCNEW (gfc_code
);
3098 assign_matmul
->op
= EXEC_ASSIGN
;
3099 assign_matmul
->loc
= co
->loc
;
3101 /* Get the bounds for the loops, create them and create the scalarized
3107 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3109 u1
= get_size_m1 (matrix_b
, 2);
3110 u2
= get_size_m1 (matrix_a
, 2);
3111 u3
= get_size_m1 (matrix_a
, 1);
3113 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3114 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3115 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3117 do_1
->block
->next
= do_2
;
3118 do_2
->block
->next
= do_3
;
3119 do_3
->block
->next
= assign_matmul
;
3121 var_1
= do_1
->ext
.iterator
->var
;
3122 var_2
= do_2
->ext
.iterator
->var
;
3123 var_3
= do_3
->ext
.iterator
->var
;
3127 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3131 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3135 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3140 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3142 u1
= get_size_m1 (matrix_b
, 1);
3143 u2
= get_size_m1 (matrix_a
, 2);
3144 u3
= get_size_m1 (matrix_a
, 1);
3146 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3147 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3148 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3150 do_1
->block
->next
= do_2
;
3151 do_2
->block
->next
= do_3
;
3152 do_3
->block
->next
= assign_matmul
;
3154 var_1
= do_1
->ext
.iterator
->var
;
3155 var_2
= do_2
->ext
.iterator
->var
;
3156 var_3
= do_3
->ext
.iterator
->var
;
3160 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3164 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3168 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3173 u1
= get_size_m1 (matrix_b
, 1);
3174 u2
= get_size_m1 (matrix_a
, 1);
3176 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3177 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3179 do_1
->block
->next
= do_2
;
3180 do_2
->block
->next
= assign_matmul
;
3182 var_1
= do_1
->ext
.iterator
->var
;
3183 var_2
= do_2
->ext
.iterator
->var
;
3186 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3190 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3193 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3198 u1
= get_size_m1 (matrix_b
, 2);
3199 u2
= get_size_m1 (matrix_a
, 1);
3201 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3202 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3204 do_1
->block
->next
= do_2
;
3205 do_2
->block
->next
= assign_matmul
;
3207 var_1
= do_1
->ext
.iterator
->var
;
3208 var_2
= do_2
->ext
.iterator
->var
;
3211 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3214 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3218 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3227 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3228 matrix_a
->where
, 1, ascalar
);
3231 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3232 matrix_b
->where
, 1, bscalar
);
3234 /* First loop comes after the zero assignment. */
3235 assign_zero
->next
= do_1
;
3237 /* Build the assignment expression in the loop. */
3238 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3240 mult
= get_operand (op_times
, ascalar
, bscalar
);
3241 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3243 /* If we don't want to keep the original statement around in
3244 the else branch, we can free it. */
3246 if (if_limit
== NULL
)
3247 gfc_free_statements(co
);
3251 gfc_free_expr (zero
);
3256 #define WALK_SUBEXPR(NODE) \
3259 result = gfc_expr_walker (&(NODE), exprfn, data); \
3264 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3266 /* Walk expression *E, calling EXPRFN on each expression in it. */
3269 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3273 int walk_subtrees
= 1;
3274 gfc_actual_arglist
*a
;
3278 int result
= exprfn (e
, &walk_subtrees
, data
);
3282 switch ((*e
)->expr_type
)
3285 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3286 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3289 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3290 WALK_SUBEXPR (a
->expr
);
3294 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3295 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3296 WALK_SUBEXPR (a
->expr
);
3299 case EXPR_STRUCTURE
:
3301 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3302 c
= gfc_constructor_next (c
))
3304 if (c
->iterator
== NULL
)
3305 WALK_SUBEXPR (c
->expr
);
3309 WALK_SUBEXPR (c
->expr
);
3311 WALK_SUBEXPR (c
->iterator
->var
);
3312 WALK_SUBEXPR (c
->iterator
->start
);
3313 WALK_SUBEXPR (c
->iterator
->end
);
3314 WALK_SUBEXPR (c
->iterator
->step
);
3318 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3321 /* Fall through to the variable case in order to walk the
3324 case EXPR_SUBSTRING
:
3326 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3335 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3337 for (i
=0; i
< ar
->dimen
; i
++)
3339 WALK_SUBEXPR (ar
->start
[i
]);
3340 WALK_SUBEXPR (ar
->end
[i
]);
3341 WALK_SUBEXPR (ar
->stride
[i
]);
3348 WALK_SUBEXPR (r
->u
.ss
.start
);
3349 WALK_SUBEXPR (r
->u
.ss
.end
);
3365 #define WALK_SUBCODE(NODE) \
3368 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3374 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3375 on each expression in it. If any of the hooks returns non-zero, that
3376 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3377 no subcodes or subexpressions are traversed. */
3380 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3383 for (; *c
; c
= &(*c
)->next
)
3385 int walk_subtrees
= 1;
3386 int result
= codefn (c
, &walk_subtrees
, data
);
3393 gfc_actual_arglist
*a
;
3395 gfc_association_list
*alist
;
3396 bool saved_in_omp_workshare
;
3397 bool saved_in_where
;
3399 /* There might be statement insertions before the current code,
3400 which must not affect the expression walker. */
3403 saved_in_omp_workshare
= in_omp_workshare
;
3404 saved_in_where
= in_where
;
3410 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3411 if (co
->ext
.block
.assoc
)
3413 bool saved_in_assoc_list
= in_assoc_list
;
3415 in_assoc_list
= true;
3416 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3417 WALK_SUBEXPR (alist
->target
);
3419 in_assoc_list
= saved_in_assoc_list
;
3426 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3427 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3428 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3429 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3437 case EXEC_ASSIGN_CALL
:
3438 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3439 WALK_SUBEXPR (a
->expr
);
3443 WALK_SUBEXPR (co
->expr1
);
3444 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3445 WALK_SUBEXPR (a
->expr
);
3449 WALK_SUBEXPR (co
->expr1
);
3450 for (b
= co
->block
; b
; b
= b
->block
)
3453 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3455 WALK_SUBEXPR (cp
->low
);
3456 WALK_SUBEXPR (cp
->high
);
3458 WALK_SUBCODE (b
->next
);
3463 case EXEC_DEALLOCATE
:
3466 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3467 WALK_SUBEXPR (a
->expr
);
3472 case EXEC_DO_CONCURRENT
:
3474 gfc_forall_iterator
*fa
;
3475 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3477 WALK_SUBEXPR (fa
->var
);
3478 WALK_SUBEXPR (fa
->start
);
3479 WALK_SUBEXPR (fa
->end
);
3480 WALK_SUBEXPR (fa
->stride
);
3482 if (co
->op
== EXEC_FORALL
)
3488 WALK_SUBEXPR (co
->ext
.open
->unit
);
3489 WALK_SUBEXPR (co
->ext
.open
->file
);
3490 WALK_SUBEXPR (co
->ext
.open
->status
);
3491 WALK_SUBEXPR (co
->ext
.open
->access
);
3492 WALK_SUBEXPR (co
->ext
.open
->form
);
3493 WALK_SUBEXPR (co
->ext
.open
->recl
);
3494 WALK_SUBEXPR (co
->ext
.open
->blank
);
3495 WALK_SUBEXPR (co
->ext
.open
->position
);
3496 WALK_SUBEXPR (co
->ext
.open
->action
);
3497 WALK_SUBEXPR (co
->ext
.open
->delim
);
3498 WALK_SUBEXPR (co
->ext
.open
->pad
);
3499 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3500 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3501 WALK_SUBEXPR (co
->ext
.open
->convert
);
3502 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3503 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3504 WALK_SUBEXPR (co
->ext
.open
->round
);
3505 WALK_SUBEXPR (co
->ext
.open
->sign
);
3506 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3507 WALK_SUBEXPR (co
->ext
.open
->id
);
3508 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3512 WALK_SUBEXPR (co
->ext
.close
->unit
);
3513 WALK_SUBEXPR (co
->ext
.close
->status
);
3514 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3515 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3518 case EXEC_BACKSPACE
:
3522 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3523 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3524 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3528 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3529 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3530 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3531 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3532 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3533 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3534 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3535 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3536 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3537 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3538 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3539 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3540 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3541 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3542 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3543 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3544 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3545 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3546 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3547 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3548 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3549 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3550 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3551 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3552 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3553 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3554 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3555 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3556 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3557 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3558 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3559 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3560 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3561 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3562 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3563 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3567 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3568 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3569 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3570 WALK_SUBEXPR (co
->ext
.wait
->id
);
3575 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3576 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3577 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3578 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3579 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3580 WALK_SUBEXPR (co
->ext
.dt
->size
);
3581 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3582 WALK_SUBEXPR (co
->ext
.dt
->id
);
3583 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3584 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3585 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3586 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3587 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3588 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3589 WALK_SUBEXPR (co
->ext
.dt
->round
);
3590 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3591 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3594 case EXEC_OMP_PARALLEL
:
3595 case EXEC_OMP_PARALLEL_DO
:
3596 case EXEC_OMP_PARALLEL_DO_SIMD
:
3597 case EXEC_OMP_PARALLEL_SECTIONS
:
3599 in_omp_workshare
= false;
3601 /* This goto serves as a shortcut to avoid code
3602 duplication or a larger if or switch statement. */
3603 goto check_omp_clauses
;
3605 case EXEC_OMP_WORKSHARE
:
3606 case EXEC_OMP_PARALLEL_WORKSHARE
:
3608 in_omp_workshare
= true;
3612 case EXEC_OMP_DISTRIBUTE
:
3613 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3614 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3615 case EXEC_OMP_DISTRIBUTE_SIMD
:
3617 case EXEC_OMP_DO_SIMD
:
3618 case EXEC_OMP_SECTIONS
:
3619 case EXEC_OMP_SINGLE
:
3620 case EXEC_OMP_END_SINGLE
:
3622 case EXEC_OMP_TARGET
:
3623 case EXEC_OMP_TARGET_DATA
:
3624 case EXEC_OMP_TARGET_TEAMS
:
3625 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3626 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3627 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3628 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3629 case EXEC_OMP_TARGET_UPDATE
:
3631 case EXEC_OMP_TEAMS
:
3632 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3633 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3634 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3635 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3637 /* Come to this label only from the
3638 EXEC_OMP_PARALLEL_* cases above. */
3642 if (co
->ext
.omp_clauses
)
3644 gfc_omp_namelist
*n
;
3645 static int list_types
[]
3646 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3647 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3649 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3650 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3651 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3652 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3653 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3654 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3655 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3656 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3657 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3658 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3660 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3662 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3664 WALK_SUBEXPR (n
->expr
);
3671 WALK_SUBEXPR (co
->expr1
);
3672 WALK_SUBEXPR (co
->expr2
);
3673 WALK_SUBEXPR (co
->expr3
);
3674 WALK_SUBEXPR (co
->expr4
);
3675 for (b
= co
->block
; b
; b
= b
->block
)
3677 WALK_SUBEXPR (b
->expr1
);
3678 WALK_SUBEXPR (b
->expr2
);
3679 WALK_SUBCODE (b
->next
);
3682 if (co
->op
== EXEC_FORALL
)
3685 if (co
->op
== EXEC_DO
)
3688 in_omp_workshare
= saved_in_omp_workshare
;
3689 in_where
= saved_in_where
;