1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2015 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"
27 #include "dependency.h"
28 #include "constructor.h"
30 #include "intrinsic.h"
32 /* Forward declarations. */
34 static void strip_function_call (gfc_expr
*);
35 static void optimize_namespace (gfc_namespace
*);
36 static void optimize_assignment (gfc_code
*);
37 static bool optimize_op (gfc_expr
*);
38 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
39 static bool optimize_trim (gfc_expr
*);
40 static bool optimize_lexical_comparison (gfc_expr
*);
41 static void optimize_minmaxloc (gfc_expr
**);
42 static bool is_empty_string (gfc_expr
*e
);
43 static void doloop_warn (gfc_namespace
*);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int inline_matmul_assign (gfc_code
**, int *, void *);
49 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
50 locus
*, gfc_namespace
*,
53 /* How deep we are inside an argument list. */
55 static int count_arglist
;
57 /* Vector of gfc_expr ** we operate on. */
59 static vec
<gfc_expr
**> expr_array
;
61 /* Pointer to the gfc_code we currently work on - to be able to insert
62 a block before the statement. */
64 static gfc_code
**current_code
;
66 /* Pointer to the block to be inserted, and the statement we are
67 changing within the block. */
69 static gfc_code
*inserted_block
, **changed_statement
;
71 /* The namespace we are currently dealing with. */
73 static gfc_namespace
*current_ns
;
75 /* If we are within any forall loop. */
77 static int forall_level
;
79 /* Keep track of whether we are within an OMP workshare. */
81 static bool in_omp_workshare
;
83 /* Keep track of iterators for array constructors. */
85 static int iterator_level
;
87 /* Keep track of DO loop levels. */
89 static vec
<gfc_code
*> doloop_list
;
91 static int doloop_level
;
93 /* Vector of gfc_expr * to keep track of DO loops. */
95 struct my_struct
*evec
;
97 /* Keep track of association lists. */
99 static bool in_assoc_list
;
101 /* Counter for temporary variables. */
103 static int var_num
= 1;
105 /* What sort of matrix we are dealing with when inlining MATMUL. */
107 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
};
109 /* Keep track of the number of expressions we have inserted so far
114 /* Entry point - run all passes for a namespace. */
117 gfc_run_passes (gfc_namespace
*ns
)
120 /* Warn about dubious DO loops where the index might
125 doloop_list
.release ();
127 if (flag_frontend_optimize
)
129 optimize_namespace (ns
);
130 optimize_reduction (ns
);
131 if (flag_dump_fortran_optimized
)
132 gfc_dump_parse_tree (ns
, stdout
);
134 expr_array
.release ();
137 if (flag_realloc_lhs
)
138 realloc_strings (ns
);
141 /* Callback for each gfc_code node invoked from check_realloc_strings.
142 For an allocatable LHS string which also appears as a variable on
154 realloc_string_callback (gfc_code
**c
, int *walk_subtrees
,
155 void *data ATTRIBUTE_UNUSED
)
157 gfc_expr
*expr1
, *expr2
;
162 if (co
->op
!= EXEC_ASSIGN
)
166 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
167 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
170 expr2
= gfc_discard_nops (co
->expr2
);
171 if (expr2
->expr_type
!= EXPR_VARIABLE
)
174 if (!gfc_check_dependency (expr1
, expr2
, true))
178 n
= create_var (expr2
, "trim");
183 /* Callback for each gfc_code node invoked through gfc_code_walker
184 from optimize_namespace. */
187 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
188 void *data ATTRIBUTE_UNUSED
)
195 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
196 || op
== EXEC_CALL_PPC
)
202 inserted_block
= NULL
;
203 changed_statement
= NULL
;
205 if (op
== EXEC_ASSIGN
)
206 optimize_assignment (*c
);
210 /* Callback for each gfc_expr node invoked through gfc_code_walker
211 from optimize_namespace. */
214 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
215 void *data ATTRIBUTE_UNUSED
)
219 if ((*e
)->expr_type
== EXPR_FUNCTION
)
222 function_expr
= true;
225 function_expr
= false;
227 if (optimize_trim (*e
))
228 gfc_simplify_expr (*e
, 0);
230 if (optimize_lexical_comparison (*e
))
231 gfc_simplify_expr (*e
, 0);
233 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
234 gfc_simplify_expr (*e
, 0);
236 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
237 switch ((*e
)->value
.function
.isym
->id
)
239 case GFC_ISYM_MINLOC
:
240 case GFC_ISYM_MAXLOC
:
241 optimize_minmaxloc (e
);
253 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
254 function is a scalar, just copy it; otherwise returns the new element, the
255 old one can be freed. */
258 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
260 gfc_expr
*fcn
, *e
= c
->expr
;
262 fcn
= gfc_copy_expr (e
);
265 gfc_constructor_base newbase
;
267 gfc_constructor
*new_c
;
270 new_expr
= gfc_get_expr ();
271 new_expr
->expr_type
= EXPR_ARRAY
;
272 new_expr
->ts
= e
->ts
;
273 new_expr
->where
= e
->where
;
275 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
276 new_c
->iterator
= c
->iterator
;
277 new_expr
->value
.constructor
= newbase
;
285 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
287 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
288 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
289 fn
->value
.function
.isym
->name
,
290 fn
->where
, 3, fcn
, NULL
, NULL
);
291 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
292 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
293 fn
->value
.function
.isym
->name
,
294 fn
->where
, 2, fcn
, NULL
);
296 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
298 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
304 /* Callback function for optimzation of reductions to scalars. Transform ANY
305 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
306 correspondingly. Handly only the simple cases without MASK and DIM. */
309 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
310 void *data ATTRIBUTE_UNUSED
)
315 gfc_actual_arglist
*a
;
316 gfc_actual_arglist
*dim
;
318 gfc_expr
*res
, *new_expr
;
319 gfc_actual_arglist
*mask
;
323 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
324 || fn
->value
.function
.isym
== NULL
)
327 id
= fn
->value
.function
.isym
->id
;
329 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
330 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
333 a
= fn
->value
.function
.actual
;
335 /* Don't handle MASK or DIM. */
339 if (dim
->expr
!= NULL
)
342 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
345 if ( mask
->expr
!= NULL
)
351 if (arg
->expr_type
!= EXPR_ARRAY
)
360 case GFC_ISYM_PRODUCT
:
361 op
= INTRINSIC_TIMES
;
376 c
= gfc_constructor_first (arg
->value
.constructor
);
378 /* Don't do any simplififcation if we have
379 - no element in the constructor or
380 - only have a single element in the array which contains an
386 res
= copy_walk_reduction_arg (c
, fn
);
388 c
= gfc_constructor_next (c
);
391 new_expr
= gfc_get_expr ();
392 new_expr
->ts
= fn
->ts
;
393 new_expr
->expr_type
= EXPR_OP
;
394 new_expr
->rank
= fn
->rank
;
395 new_expr
->where
= fn
->where
;
396 new_expr
->value
.op
.op
= op
;
397 new_expr
->value
.op
.op1
= res
;
398 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
400 c
= gfc_constructor_next (c
);
403 gfc_simplify_expr (res
, 0);
410 /* Callback function for common function elimination, called from cfe_expr_0.
411 Put all eligible function expressions into expr_array. */
414 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
415 void *data ATTRIBUTE_UNUSED
)
418 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
421 /* We don't do character functions with unknown charlens. */
422 if ((*e
)->ts
.type
== BT_CHARACTER
423 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
424 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
427 /* We don't do function elimination within FORALL statements, it can
428 lead to wrong-code in certain circumstances. */
430 if (forall_level
> 0)
433 /* Function elimination inside an iterator could lead to functions which
434 depend on iterator variables being moved outside. FIXME: We should check
435 if the functions do indeed depend on the iterator variable. */
437 if (iterator_level
> 0)
440 /* If we don't know the shape at compile time, we create an allocatable
441 temporary variable to hold the intermediate result, but only if
442 allocation on assignment is active. */
444 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
447 /* Skip the test for pure functions if -faggressive-function-elimination
449 if ((*e
)->value
.function
.esym
)
451 /* Don't create an array temporary for elemental functions. */
452 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
455 /* Only eliminate potentially impure functions if the
456 user specifically requested it. */
457 if (!flag_aggressive_function_elimination
458 && !(*e
)->value
.function
.esym
->attr
.pure
459 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
463 if ((*e
)->value
.function
.isym
)
465 /* Conversions are handled on the fly by the middle end,
466 transpose during trans-* stages and TRANSFER by the middle end. */
467 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
468 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
469 || gfc_inline_intrinsic_function_p (*e
))
472 /* Don't create an array temporary for elemental functions,
473 as this would be wasteful of memory.
474 FIXME: Create a scalar temporary during scalarization. */
475 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
478 if (!(*e
)->value
.function
.isym
->pure
)
482 expr_array
.safe_push (e
);
486 /* Auxiliary function to check if an expression is a temporary created by
490 is_fe_temp (gfc_expr
*e
)
492 if (e
->expr_type
!= EXPR_VARIABLE
)
495 return e
->symtree
->n
.sym
->attr
.fe_temp
;
498 /* Determine the length of a string, if it can be evaluated as a constant
499 expression. Return a newly allocated gfc_expr or NULL on failure.
500 If the user specified a substring which is potentially longer than
501 the string itself, the string will be padded with spaces, which
505 constant_string_length (gfc_expr
*e
)
515 length
= e
->ts
.u
.cl
->length
;
516 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
517 return gfc_copy_expr(length
);
520 /* Return length of substring, if constant. */
521 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
523 if (ref
->type
== REF_SUBSTRING
524 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
526 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
529 mpz_add_ui (res
->value
.integer
, value
, 1);
535 /* Return length of char symbol, if constant. */
537 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
538 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
539 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
545 /* Insert a block at the current position unless it has already
546 been inserted; in this case use the one already there. */
548 static gfc_namespace
*
553 /* If the block hasn't already been created, do so. */
554 if (inserted_block
== NULL
)
556 inserted_block
= XCNEW (gfc_code
);
557 inserted_block
->op
= EXEC_BLOCK
;
558 inserted_block
->loc
= (*current_code
)->loc
;
559 ns
= gfc_build_block_ns (current_ns
);
560 inserted_block
->ext
.block
.ns
= ns
;
561 inserted_block
->ext
.block
.assoc
= NULL
;
563 ns
->code
= *current_code
;
565 /* If the statement has a label, make sure it is transferred to
566 the newly created block. */
568 if ((*current_code
)->here
)
570 inserted_block
->here
= (*current_code
)->here
;
571 (*current_code
)->here
= NULL
;
574 inserted_block
->next
= (*current_code
)->next
;
575 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
576 (*current_code
)->next
= NULL
;
577 /* Insert the BLOCK at the right position. */
578 *current_code
= inserted_block
;
579 ns
->parent
= current_ns
;
582 ns
= inserted_block
->ext
.block
.ns
;
587 /* Returns a new expression (a variable) to be used in place of the old one,
588 with an optional assignment statement before the current statement to set
589 the value of the variable. Creates a new BLOCK for the statement if that
590 hasn't already been done and puts the statement, plus the newly created
591 variables, in that block. Special cases: If the expression is constant or
592 a temporary which has already been created, just copy it. */
595 create_var (gfc_expr
* e
, const char *vname
)
597 char name
[GFC_MAX_SYMBOL_LEN
+1];
598 gfc_symtree
*symtree
;
605 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
606 return gfc_copy_expr (e
);
608 ns
= insert_block ();
611 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
613 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
615 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
618 symbol
= symtree
->n
.sym
;
623 symbol
->as
= gfc_get_array_spec ();
624 symbol
->as
->rank
= e
->rank
;
626 if (e
->shape
== NULL
)
628 /* We don't know the shape at compile time, so we use an
630 symbol
->as
->type
= AS_DEFERRED
;
631 symbol
->attr
.allocatable
= 1;
635 symbol
->as
->type
= AS_EXPLICIT
;
636 /* Copy the shape. */
637 for (i
=0; i
<e
->rank
; i
++)
641 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
643 mpz_set_si (p
->value
.integer
, 1);
644 symbol
->as
->lower
[i
] = p
;
646 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
648 mpz_set (q
->value
.integer
, e
->shape
[i
]);
649 symbol
->as
->upper
[i
] = q
;
654 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
658 length
= constant_string_length (e
);
661 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
662 symbol
->ts
.u
.cl
->length
= length
;
665 symbol
->attr
.allocatable
= 1;
668 symbol
->attr
.flavor
= FL_VARIABLE
;
669 symbol
->attr
.referenced
= 1;
670 symbol
->attr
.dimension
= e
->rank
> 0;
671 symbol
->attr
.fe_temp
= 1;
672 gfc_commit_symbol (symbol
);
674 result
= gfc_get_expr ();
675 result
->expr_type
= EXPR_VARIABLE
;
677 result
->rank
= e
->rank
;
678 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
679 result
->symtree
= symtree
;
680 result
->where
= e
->where
;
683 result
->ref
= gfc_get_ref ();
684 result
->ref
->type
= REF_ARRAY
;
685 result
->ref
->u
.ar
.type
= AR_FULL
;
686 result
->ref
->u
.ar
.where
= e
->where
;
687 result
->ref
->u
.ar
.dimen
= e
->rank
;
688 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
689 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
690 if (warn_array_temporaries
)
691 gfc_warning (OPT_Warray_temporaries
,
692 "Creating array temporary at %L", &(e
->where
));
695 /* Generate the new assignment. */
696 n
= XCNEW (gfc_code
);
698 n
->loc
= (*current_code
)->loc
;
699 n
->next
= *changed_statement
;
700 n
->expr1
= gfc_copy_expr (result
);
702 *changed_statement
= n
;
708 /* Warn about function elimination. */
711 do_warn_function_elimination (gfc_expr
*e
)
713 if (e
->expr_type
!= EXPR_FUNCTION
)
715 if (e
->value
.function
.esym
)
716 gfc_warning (0, "Removing call to function %qs at %L",
717 e
->value
.function
.esym
->name
, &(e
->where
));
718 else if (e
->value
.function
.isym
)
719 gfc_warning (0, "Removing call to function %qs at %L",
720 e
->value
.function
.isym
->name
, &(e
->where
));
722 /* Callback function for the code walker for doing common function
723 elimination. This builds up the list of functions in the expression
724 and goes through them to detect duplicates, which it then replaces
728 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
729 void *data ATTRIBUTE_UNUSED
)
735 /* Don't do this optimization within OMP workshare. */
737 if (in_omp_workshare
)
743 expr_array
.release ();
745 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
747 /* Walk through all the functions. */
749 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
751 /* Skip if the function has been replaced by a variable already. */
752 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
759 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
762 newvar
= create_var (*ei
, "fcn");
764 if (warn_function_elimination
)
765 do_warn_function_elimination (*ej
);
768 *ej
= gfc_copy_expr (newvar
);
775 /* We did all the necessary walking in this function. */
780 /* Callback function for common function elimination, called from
781 gfc_code_walker. This keeps track of the current code, in order
782 to insert statements as needed. */
785 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
788 inserted_block
= NULL
;
789 changed_statement
= NULL
;
791 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
792 and allocation on assigment are prohibited inside WHERE, and finally
793 masking an expression would lead to wrong-code when replacing
796 b = sum(foo(a) + foo(a))
807 if ((*c
)->op
== EXEC_WHERE
)
817 /* Dummy function for expression call back, for use when we
818 really don't want to do any walking. */
821 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
822 void *data ATTRIBUTE_UNUSED
)
828 /* Dummy function for code callback, for use when we really
829 don't want to do anything. */
831 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
832 int *walk_subtrees ATTRIBUTE_UNUSED
,
833 void *data ATTRIBUTE_UNUSED
)
838 /* Code callback function for converting
845 This is because common function elimination would otherwise place the
846 temporary variables outside the loop. */
849 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
850 void *data ATTRIBUTE_UNUSED
)
853 gfc_code
*c_if1
, *c_if2
, *c_exit
;
855 gfc_expr
*e_not
, *e_cond
;
857 if (co
->op
!= EXEC_DO_WHILE
)
860 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
865 /* Generate the condition of the if statement, which is .not. the original
867 e_not
= gfc_get_expr ();
868 e_not
->ts
= e_cond
->ts
;
869 e_not
->where
= e_cond
->where
;
870 e_not
->expr_type
= EXPR_OP
;
871 e_not
->value
.op
.op
= INTRINSIC_NOT
;
872 e_not
->value
.op
.op1
= e_cond
;
874 /* Generate the EXIT statement. */
875 c_exit
= XCNEW (gfc_code
);
876 c_exit
->op
= EXEC_EXIT
;
877 c_exit
->ext
.which_construct
= co
;
878 c_exit
->loc
= co
->loc
;
880 /* Generate the IF statement. */
881 c_if2
= XCNEW (gfc_code
);
883 c_if2
->expr1
= e_not
;
884 c_if2
->next
= c_exit
;
885 c_if2
->loc
= co
->loc
;
887 /* ... plus the one to chain it to. */
888 c_if1
= XCNEW (gfc_code
);
890 c_if1
->block
= c_if2
;
891 c_if1
->loc
= co
->loc
;
893 /* Make the DO WHILE loop into a DO block by replacing the condition
894 with a true constant. */
895 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
897 /* Hang the generated if statement into the loop body. */
899 loopblock
= co
->block
->next
;
900 co
->block
->next
= c_if1
;
901 c_if1
->next
= loopblock
;
906 /* Code callback function for converting
919 because otherwise common function elimination would place the BLOCKs
920 into the wrong place. */
923 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
924 void *data ATTRIBUTE_UNUSED
)
927 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
929 if (co
->op
!= EXEC_IF
)
932 /* This loop starts out with the first ELSE statement. */
933 else_stmt
= co
->block
->block
;
935 while (else_stmt
!= NULL
)
939 /* If there is no condition, we're done. */
940 if (else_stmt
->expr1
== NULL
)
943 next_else
= else_stmt
->block
;
945 /* Generate the new IF statement. */
946 c_if2
= XCNEW (gfc_code
);
948 c_if2
->expr1
= else_stmt
->expr1
;
949 c_if2
->next
= else_stmt
->next
;
950 c_if2
->loc
= else_stmt
->loc
;
951 c_if2
->block
= next_else
;
953 /* ... plus the one to chain it to. */
954 c_if1
= XCNEW (gfc_code
);
956 c_if1
->block
= c_if2
;
957 c_if1
->loc
= else_stmt
->loc
;
959 /* Insert the new IF after the ELSE. */
960 else_stmt
->expr1
= NULL
;
961 else_stmt
->next
= c_if1
;
962 else_stmt
->block
= NULL
;
964 else_stmt
= next_else
;
966 /* Don't walk subtrees. */
970 /* Optimize a namespace, including all contained namespaces. */
973 optimize_namespace (gfc_namespace
*ns
)
975 gfc_namespace
*saved_ns
= gfc_current_ns
;
980 in_assoc_list
= false;
981 in_omp_workshare
= false;
983 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
984 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
985 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
986 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
987 if (flag_inline_matmul_limit
!= 0)
988 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
991 /* BLOCKs are handled in the expression walker below. */
992 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
994 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
995 optimize_namespace (ns
);
997 gfc_current_ns
= saved_ns
;
1000 /* Handle dependencies for allocatable strings which potentially redefine
1001 themselves in an assignment. */
1004 realloc_strings (gfc_namespace
*ns
)
1007 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1009 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1011 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1012 realloc_strings (ns
);
1018 optimize_reduction (gfc_namespace
*ns
)
1021 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1022 callback_reduction
, NULL
);
1024 /* BLOCKs are handled in the expression walker below. */
1025 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1027 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1028 optimize_reduction (ns
);
1032 /* Replace code like
1035 a = matmul(b,c) ; a = a + d
1036 where the array function is not elemental and not allocatable
1037 and does not depend on the left-hand side.
1041 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1046 if (e
->expr_type
== EXPR_OP
)
1048 switch (e
->value
.op
.op
)
1050 /* Unary operators and exponentiation: Only look at a single
1053 case INTRINSIC_UPLUS
:
1054 case INTRINSIC_UMINUS
:
1055 case INTRINSIC_PARENTHESES
:
1056 case INTRINSIC_POWER
:
1057 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1061 case INTRINSIC_CONCAT
:
1062 /* Do not do string concatenations. */
1066 /* Binary operators. */
1067 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1070 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1076 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1077 && ! (e
->value
.function
.esym
1078 && (e
->value
.function
.esym
->attr
.elemental
1079 || e
->value
.function
.esym
->attr
.allocatable
1080 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1081 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1082 && ! (e
->value
.function
.isym
1083 && (e
->value
.function
.isym
->elemental
1084 || e
->ts
.type
!= c
->expr1
->ts
.type
1085 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1086 && ! gfc_inline_intrinsic_function_p (e
))
1092 /* Insert a new assignment statement after the current one. */
1093 n
= XCNEW (gfc_code
);
1094 n
->op
= EXEC_ASSIGN
;
1099 n
->expr1
= gfc_copy_expr (c
->expr1
);
1100 n
->expr2
= c
->expr2
;
1101 new_expr
= gfc_copy_expr (c
->expr1
);
1109 /* Nothing to optimize. */
1113 /* Remove unneeded TRIMs at the end of expressions. */
1116 remove_trim (gfc_expr
*rhs
)
1122 /* Check for a // b // trim(c). Looping is probably not
1123 necessary because the parser usually generates
1124 (// (// a b ) trim(c) ) , but better safe than sorry. */
1126 while (rhs
->expr_type
== EXPR_OP
1127 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1128 rhs
= rhs
->value
.op
.op2
;
1130 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1131 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1133 strip_function_call (rhs
);
1134 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1142 /* Optimizations for an assignment. */
1145 optimize_assignment (gfc_code
* c
)
1147 gfc_expr
*lhs
, *rhs
;
1152 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1154 /* Optimize a = trim(b) to a = b. */
1157 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1158 if (is_empty_string (rhs
))
1159 rhs
->value
.character
.length
= 0;
1162 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1163 optimize_binop_array_assignment (c
, &rhs
, false);
1167 /* Remove an unneeded function call, modifying the expression.
1168 This replaces the function call with the value of its
1169 first argument. The rest of the argument list is freed. */
1172 strip_function_call (gfc_expr
*e
)
1175 gfc_actual_arglist
*a
;
1177 a
= e
->value
.function
.actual
;
1179 /* We should have at least one argument. */
1180 gcc_assert (a
->expr
!= NULL
);
1184 /* Free the remaining arglist, if any. */
1186 gfc_free_actual_arglist (a
->next
);
1188 /* Graft the argument expression onto the original function. */
1194 /* Optimization of lexical comparison functions. */
1197 optimize_lexical_comparison (gfc_expr
*e
)
1199 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1202 switch (e
->value
.function
.isym
->id
)
1205 return optimize_comparison (e
, INTRINSIC_LE
);
1208 return optimize_comparison (e
, INTRINSIC_GE
);
1211 return optimize_comparison (e
, INTRINSIC_GT
);
1214 return optimize_comparison (e
, INTRINSIC_LT
);
1222 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1223 do CHARACTER because of possible pessimization involving character
1227 combine_array_constructor (gfc_expr
*e
)
1230 gfc_expr
*op1
, *op2
;
1233 gfc_constructor
*c
, *new_c
;
1234 gfc_constructor_base oldbase
, newbase
;
1237 /* Array constructors have rank one. */
1241 /* Don't try to combine association lists, this makes no sense
1242 and leads to an ICE. */
1246 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1247 if (forall_level
> 0)
1250 op1
= e
->value
.op
.op1
;
1251 op2
= e
->value
.op
.op2
;
1253 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1254 scalar_first
= false;
1255 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1257 scalar_first
= true;
1258 op1
= e
->value
.op
.op2
;
1259 op2
= e
->value
.op
.op1
;
1264 if (op2
->ts
.type
== BT_CHARACTER
)
1267 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1269 oldbase
= op1
->value
.constructor
;
1271 e
->expr_type
= EXPR_ARRAY
;
1273 for (c
= gfc_constructor_first (oldbase
); c
;
1274 c
= gfc_constructor_next (c
))
1276 new_expr
= gfc_get_expr ();
1277 new_expr
->ts
= e
->ts
;
1278 new_expr
->expr_type
= EXPR_OP
;
1279 new_expr
->rank
= c
->expr
->rank
;
1280 new_expr
->where
= c
->where
;
1281 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1285 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1286 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1290 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1291 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1294 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1295 new_c
->iterator
= c
->iterator
;
1299 gfc_free_expr (op1
);
1300 gfc_free_expr (op2
);
1301 gfc_free_expr (scalar
);
1303 e
->value
.constructor
= newbase
;
1307 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1308 2**k into ishift(1,k) */
1311 optimize_power (gfc_expr
*e
)
1313 gfc_expr
*op1
, *op2
;
1314 gfc_expr
*iand
, *ishft
;
1316 if (e
->ts
.type
!= BT_INTEGER
)
1319 op1
= e
->value
.op
.op1
;
1321 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1324 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1326 gfc_free_expr (op1
);
1328 op2
= e
->value
.op
.op2
;
1333 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1334 "_internal_iand", e
->where
, 2, op2
,
1335 gfc_get_int_expr (e
->ts
.kind
,
1338 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1339 "_internal_ishft", e
->where
, 2, iand
,
1340 gfc_get_int_expr (e
->ts
.kind
,
1343 e
->value
.op
.op
= INTRINSIC_MINUS
;
1344 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1345 e
->value
.op
.op2
= ishft
;
1348 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1350 gfc_free_expr (op1
);
1352 op2
= e
->value
.op
.op2
;
1356 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1357 "_internal_ishft", e
->where
, 2,
1358 gfc_get_int_expr (e
->ts
.kind
,
1365 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1367 op2
= e
->value
.op
.op2
;
1371 gfc_free_expr (op1
);
1372 gfc_free_expr (op2
);
1374 e
->expr_type
= EXPR_CONSTANT
;
1375 e
->value
.op
.op1
= NULL
;
1376 e
->value
.op
.op2
= NULL
;
1377 mpz_init_set_si (e
->value
.integer
, 1);
1378 /* Typespec and location are still OK. */
1385 /* Recursive optimization of operators. */
1388 optimize_op (gfc_expr
*e
)
1392 gfc_intrinsic_op op
= e
->value
.op
.op
;
1396 /* Only use new-style comparisons. */
1399 case INTRINSIC_EQ_OS
:
1403 case INTRINSIC_GE_OS
:
1407 case INTRINSIC_LE_OS
:
1411 case INTRINSIC_NE_OS
:
1415 case INTRINSIC_GT_OS
:
1419 case INTRINSIC_LT_OS
:
1435 changed
= optimize_comparison (e
, op
);
1438 /* Look at array constructors. */
1439 case INTRINSIC_PLUS
:
1440 case INTRINSIC_MINUS
:
1441 case INTRINSIC_TIMES
:
1442 case INTRINSIC_DIVIDE
:
1443 return combine_array_constructor (e
) || changed
;
1445 case INTRINSIC_POWER
:
1446 return optimize_power (e
);
1457 /* Return true if a constant string contains only blanks. */
1460 is_empty_string (gfc_expr
*e
)
1464 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1467 for (i
=0; i
< e
->value
.character
.length
; i
++)
1469 if (e
->value
.character
.string
[i
] != ' ')
1477 /* Insert a call to the intrinsic len_trim. Use a different name for
1478 the symbol tree so we don't run into trouble when the user has
1479 renamed len_trim for some reason. */
1482 get_len_trim_call (gfc_expr
*str
, int kind
)
1485 gfc_actual_arglist
*actual_arglist
, *next
;
1487 fcn
= gfc_get_expr ();
1488 fcn
->expr_type
= EXPR_FUNCTION
;
1489 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1490 actual_arglist
= gfc_get_actual_arglist ();
1491 actual_arglist
->expr
= str
;
1492 next
= gfc_get_actual_arglist ();
1493 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1494 actual_arglist
->next
= next
;
1496 fcn
->value
.function
.actual
= actual_arglist
;
1497 fcn
->where
= str
->where
;
1498 fcn
->ts
.type
= BT_INTEGER
;
1499 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1501 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1502 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1503 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1504 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1505 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1506 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1507 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1508 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1513 /* Optimize expressions for equality. */
1516 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1518 gfc_expr
*op1
, *op2
;
1522 gfc_actual_arglist
*firstarg
, *secondarg
;
1524 if (e
->expr_type
== EXPR_OP
)
1528 op1
= e
->value
.op
.op1
;
1529 op2
= e
->value
.op
.op2
;
1531 else if (e
->expr_type
== EXPR_FUNCTION
)
1533 /* One of the lexical comparison functions. */
1534 firstarg
= e
->value
.function
.actual
;
1535 secondarg
= firstarg
->next
;
1536 op1
= firstarg
->expr
;
1537 op2
= secondarg
->expr
;
1542 /* Strip off unneeded TRIM calls from string comparisons. */
1544 change
= remove_trim (op1
);
1546 if (remove_trim (op2
))
1549 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1550 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1551 handles them well). However, there are also cases that need a non-scalar
1552 argument. For example the any intrinsic. See PR 45380. */
1556 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1558 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1559 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1561 bool empty_op1
, empty_op2
;
1562 empty_op1
= is_empty_string (op1
);
1563 empty_op2
= is_empty_string (op2
);
1565 if (empty_op1
|| empty_op2
)
1571 /* This can only happen when an error for comparing
1572 characters of different kinds has already been issued. */
1573 if (empty_op1
&& empty_op2
)
1576 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1577 str
= empty_op1
? op2
: op1
;
1579 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1583 gfc_free_expr (op1
);
1585 gfc_free_expr (op2
);
1589 e
->value
.op
.op1
= fcn
;
1590 e
->value
.op
.op2
= zero
;
1595 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1597 if (flag_finite_math_only
1598 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1599 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1601 eq
= gfc_dep_compare_expr (op1
, op2
);
1604 /* Replace A // B < A // C with B < C, and A // B < C // B
1606 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1607 && op1
->expr_type
== EXPR_OP
1608 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1609 && op2
->expr_type
== EXPR_OP
1610 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1612 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1613 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1614 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1615 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1617 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1619 /* Watch out for 'A ' // x vs. 'A' // x. */
1621 if (op1_left
->expr_type
== EXPR_CONSTANT
1622 && op2_left
->expr_type
== EXPR_CONSTANT
1623 && op1_left
->value
.character
.length
1624 != op2_left
->value
.character
.length
)
1632 firstarg
->expr
= op1_right
;
1633 secondarg
->expr
= op2_right
;
1637 e
->value
.op
.op1
= op1_right
;
1638 e
->value
.op
.op2
= op2_right
;
1640 optimize_comparison (e
, op
);
1644 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1650 firstarg
->expr
= op1_left
;
1651 secondarg
->expr
= op2_left
;
1655 e
->value
.op
.op1
= op1_left
;
1656 e
->value
.op
.op2
= op2_left
;
1659 optimize_comparison (e
, op
);
1666 /* eq can only be -1, 0 or 1 at this point. */
1694 gfc_internal_error ("illegal OP in optimize_comparison");
1698 /* Replace the expression by a constant expression. The typespec
1699 and where remains the way it is. */
1702 e
->expr_type
= EXPR_CONSTANT
;
1703 e
->value
.logical
= result
;
1711 /* Optimize a trim function by replacing it with an equivalent substring
1712 involving a call to len_trim. This only works for expressions where
1713 variables are trimmed. Return true if anything was modified. */
1716 optimize_trim (gfc_expr
*e
)
1721 gfc_ref
**rr
= NULL
;
1723 /* Don't do this optimization within an argument list, because
1724 otherwise aliasing issues may occur. */
1726 if (count_arglist
!= 1)
1729 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1730 || e
->value
.function
.isym
== NULL
1731 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1734 a
= e
->value
.function
.actual
->expr
;
1736 if (a
->expr_type
!= EXPR_VARIABLE
)
1739 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1741 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1744 /* Follow all references to find the correct place to put the newly
1745 created reference. FIXME: Also handle substring references and
1746 array references. Array references cause strange regressions at
1751 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1753 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1758 strip_function_call (e
);
1763 /* Create the reference. */
1765 ref
= gfc_get_ref ();
1766 ref
->type
= REF_SUBSTRING
;
1768 /* Set the start of the reference. */
1770 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1772 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1774 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1776 /* Set the end of the reference to the call to len_trim. */
1778 ref
->u
.ss
.end
= fcn
;
1779 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1784 /* Optimize minloc(b), where b is rank 1 array, into
1785 (/ minloc(b, dim=1) /), and similarly for maxloc,
1786 as the latter forms are expanded inline. */
1789 optimize_minmaxloc (gfc_expr
**e
)
1792 gfc_actual_arglist
*a
;
1796 || fn
->value
.function
.actual
== NULL
1797 || fn
->value
.function
.actual
->expr
== NULL
1798 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1801 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1802 (*e
)->shape
= fn
->shape
;
1805 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1807 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1808 strcpy (name
, fn
->value
.function
.name
);
1809 p
= strstr (name
, "loc0");
1811 fn
->value
.function
.name
= gfc_get_string (name
);
1812 if (fn
->value
.function
.actual
->next
)
1814 a
= fn
->value
.function
.actual
->next
;
1815 gcc_assert (a
->expr
== NULL
);
1819 a
= gfc_get_actual_arglist ();
1820 fn
->value
.function
.actual
->next
= a
;
1822 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1824 mpz_set_ui (a
->expr
->value
.integer
, 1);
1827 /* Callback function for code checking that we do not pass a DO variable to an
1828 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1831 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1832 void *data ATTRIBUTE_UNUSED
)
1836 gfc_formal_arglist
*f
;
1837 gfc_actual_arglist
*a
;
1842 /* If the doloop_list grew, we have to truncate it here. */
1844 if ((unsigned) doloop_level
< doloop_list
.length())
1845 doloop_list
.truncate (doloop_level
);
1851 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1852 doloop_list
.safe_push (co
);
1854 doloop_list
.safe_push ((gfc_code
*) NULL
);
1859 if (co
->resolved_sym
== NULL
)
1862 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1864 /* Withot a formal arglist, there is only unknown INTENT,
1865 which we don't check for. */
1873 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1880 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1882 if (a
->expr
&& a
->expr
->symtree
1883 && a
->expr
->symtree
->n
.sym
== do_sym
)
1885 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1886 gfc_error_now ("Variable %qs at %L set to undefined "
1887 "value inside loop beginning at %L as "
1888 "INTENT(OUT) argument to subroutine %qs",
1889 do_sym
->name
, &a
->expr
->where
,
1890 &doloop_list
[i
]->loc
,
1891 co
->symtree
->n
.sym
->name
);
1892 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1893 gfc_error_now ("Variable %qs at %L not definable inside "
1894 "loop beginning at %L as INTENT(INOUT) "
1895 "argument to subroutine %qs",
1896 do_sym
->name
, &a
->expr
->where
,
1897 &doloop_list
[i
]->loc
,
1898 co
->symtree
->n
.sym
->name
);
1912 /* Callback function for functions checking that we do not pass a DO variable
1913 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1916 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1917 void *data ATTRIBUTE_UNUSED
)
1919 gfc_formal_arglist
*f
;
1920 gfc_actual_arglist
*a
;
1926 if (expr
->expr_type
!= EXPR_FUNCTION
)
1929 /* Intrinsic functions don't modify their arguments. */
1931 if (expr
->value
.function
.isym
)
1934 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1936 /* Without a formal arglist, there is only unknown INTENT,
1937 which we don't check for. */
1941 a
= expr
->value
.function
.actual
;
1945 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1952 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1954 if (a
->expr
&& a
->expr
->symtree
1955 && a
->expr
->symtree
->n
.sym
== do_sym
)
1957 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1958 gfc_error_now ("Variable %qs at %L set to undefined value "
1959 "inside loop beginning at %L as INTENT(OUT) "
1960 "argument to function %qs", do_sym
->name
,
1961 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1962 expr
->symtree
->n
.sym
->name
);
1963 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1964 gfc_error_now ("Variable %qs at %L not definable inside loop"
1965 " beginning at %L as INTENT(INOUT) argument to"
1966 " function %qs", do_sym
->name
,
1967 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1968 expr
->symtree
->n
.sym
->name
);
1979 doloop_warn (gfc_namespace
*ns
)
1981 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1984 /* This selction deals with inlining calls to MATMUL. */
1986 /* Auxiliary function to build and simplify an array inquiry function.
1987 dim is zero-based. */
1990 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
1993 gfc_expr
*dim_arg
, *kind
;
1999 case GFC_ISYM_LBOUND
:
2000 name
= "_gfortran_lbound";
2003 case GFC_ISYM_UBOUND
:
2004 name
= "_gfortran_ubound";
2008 name
= "_gfortran_size";
2015 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2016 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2017 gfc_index_integer_kind
);
2019 ec
= gfc_copy_expr (e
);
2020 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2022 gfc_simplify_expr (fcn
, 0);
2026 /* Builds a logical expression. */
2029 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2034 ts
.type
= BT_LOGICAL
;
2035 ts
.kind
= gfc_default_logical_kind
;
2036 res
= gfc_get_expr ();
2037 res
->where
= e1
->where
;
2038 res
->expr_type
= EXPR_OP
;
2039 res
->value
.op
.op
= op
;
2040 res
->value
.op
.op1
= e1
;
2041 res
->value
.op
.op2
= e2
;
2048 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2049 compatible typespecs. */
2052 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2056 res
= gfc_get_expr ();
2058 res
->where
= e1
->where
;
2059 res
->expr_type
= EXPR_OP
;
2060 res
->value
.op
.op
= op
;
2061 res
->value
.op
.op1
= e1
;
2062 res
->value
.op
.op2
= e2
;
2063 gfc_simplify_expr (res
, 0);
2067 /* Generate the IF statement for a runtime check if we want to do inlining or
2068 not - putting in the code for both branches and putting it into the syntax
2069 tree is the caller's responsibility. For fixed array sizes, this should be
2070 removed by DCE. Only called for rank-two matrices A and B. */
2073 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2075 gfc_expr
*inline_limit
;
2076 gfc_code
*if_1
, *if_2
, *else_2
;
2077 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2081 gcc_assert (m_case
== A2B2
);
2083 /* Calculation is done in real to avoid integer overflow. */
2085 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2087 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2089 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2092 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2093 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2094 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2098 ts
.kind
= gfc_default_real_kind
;
2099 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2100 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2101 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2103 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2104 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2106 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2107 gfc_simplify_expr (cond
, 0);
2109 else_2
= XCNEW (gfc_code
);
2110 else_2
->op
= EXEC_IF
;
2111 else_2
->loc
= a
->where
;
2113 if_2
= XCNEW (gfc_code
);
2116 if_2
->loc
= a
->where
;
2117 if_2
->block
= else_2
;
2119 if_1
= XCNEW (gfc_code
);
2122 if_1
->loc
= a
->where
;
2128 /* Insert code to issue a runtime error if the expressions are not equal. */
2131 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2134 gfc_code
*if_1
, *if_2
;
2136 gfc_actual_arglist
*a1
, *a2
, *a3
;
2138 gcc_assert (e1
->where
.lb
);
2139 /* Build the call to runtime_error. */
2140 c
= XCNEW (gfc_code
);
2144 /* Get a null-terminated message string. */
2146 a1
= gfc_get_actual_arglist ();
2147 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2148 msg
, strlen(msg
)+1);
2151 /* Pass the value of the first expression. */
2152 a2
= gfc_get_actual_arglist ();
2153 a2
->expr
= gfc_copy_expr (e1
);
2156 /* Pass the value of the second expression. */
2157 a3
= gfc_get_actual_arglist ();
2158 a3
->expr
= gfc_copy_expr (e2
);
2161 gfc_check_fe_runtime_error (c
->ext
.actual
);
2162 gfc_resolve_fe_runtime_error (c
);
2164 if_2
= XCNEW (gfc_code
);
2166 if_2
->loc
= e1
->where
;
2169 if_1
= XCNEW (gfc_code
);
2172 if_1
->loc
= e1
->where
;
2174 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2175 gfc_simplify_expr (cond
, 0);
2181 /* Handle matrix reallocation. Caller is responsible to insert into
2184 For the two-dimensional case, build
2186 if (allocated(c)) then
2187 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2189 allocate (c(size(a,1), size(b,2)))
2192 allocate (c(size(a,1),size(b,2)))
2195 and for the other cases correspondingly.
2199 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2200 enum matrix_case m_case
)
2203 gfc_expr
*allocated
, *alloc_expr
;
2204 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2205 gfc_code
*else_alloc
;
2206 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2208 gfc_expr
*cond
, *ne1
, *ne2
;
2210 if (warn_realloc_lhs
)
2211 gfc_warning (OPT_Wrealloc_lhs
,
2212 "Code for reallocating the allocatable array at %L will "
2213 "be added", &c
->where
);
2215 alloc_expr
= gfc_copy_expr (c
);
2217 ar
= gfc_find_array_ref (alloc_expr
);
2218 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2220 /* c comes in as a full ref. Change it into a copy and make it into an
2221 element ref so it has the right form for for ALLOCATE. In the same
2222 switch statement, also generate the size comparison for the secod IF
2225 ar
->type
= AR_ELEMENT
;
2230 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2231 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2232 ne1
= build_logical_expr (INTRINSIC_NE
,
2233 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2234 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2235 ne2
= build_logical_expr (INTRINSIC_NE
,
2236 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2237 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2238 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2242 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2243 cond
= build_logical_expr (INTRINSIC_NE
,
2244 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2245 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2249 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2250 cond
= build_logical_expr (INTRINSIC_NE
,
2251 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2252 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2260 gfc_simplify_expr (cond
, 0);
2262 /* We need two identical allocate statements in two
2263 branches of the IF statement. */
2265 allocate1
= XCNEW (gfc_code
);
2266 allocate1
->op
= EXEC_ALLOCATE
;
2267 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2268 allocate1
->loc
= c
->where
;
2269 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2271 allocate_else
= XCNEW (gfc_code
);
2272 allocate_else
->op
= EXEC_ALLOCATE
;
2273 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2274 allocate_else
->loc
= c
->where
;
2275 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2277 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2278 "_gfortran_allocated", c
->where
,
2279 1, gfc_copy_expr (c
));
2281 deallocate
= XCNEW (gfc_code
);
2282 deallocate
->op
= EXEC_DEALLOCATE
;
2283 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2284 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2285 deallocate
->next
= allocate1
;
2286 deallocate
->loc
= c
->where
;
2288 if_size_2
= XCNEW (gfc_code
);
2289 if_size_2
->op
= EXEC_IF
;
2290 if_size_2
->expr1
= cond
;
2291 if_size_2
->loc
= c
->where
;
2292 if_size_2
->next
= deallocate
;
2294 if_size_1
= XCNEW (gfc_code
);
2295 if_size_1
->op
= EXEC_IF
;
2296 if_size_1
->block
= if_size_2
;
2297 if_size_1
->loc
= c
->where
;
2299 else_alloc
= XCNEW (gfc_code
);
2300 else_alloc
->op
= EXEC_IF
;
2301 else_alloc
->loc
= c
->where
;
2302 else_alloc
->next
= allocate_else
;
2304 if_alloc_2
= XCNEW (gfc_code
);
2305 if_alloc_2
->op
= EXEC_IF
;
2306 if_alloc_2
->expr1
= allocated
;
2307 if_alloc_2
->loc
= c
->where
;
2308 if_alloc_2
->next
= if_size_1
;
2309 if_alloc_2
->block
= else_alloc
;
2311 if_alloc_1
= XCNEW (gfc_code
);
2312 if_alloc_1
->op
= EXEC_IF
;
2313 if_alloc_1
->block
= if_alloc_2
;
2314 if_alloc_1
->loc
= c
->where
;
2319 /* Callback function for has_function_or_op. */
2322 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2323 void *data ATTRIBUTE_UNUSED
)
2328 return (*e
)->expr_type
== EXPR_FUNCTION
2329 || (*e
)->expr_type
== EXPR_OP
;
2332 /* Returns true if the expression contains a function. */
2335 has_function_or_op (gfc_expr
**e
)
2340 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2343 /* Freeze (assign to a temporary variable) a single expression. */
2346 freeze_expr (gfc_expr
**ep
)
2349 if (has_function_or_op (ep
))
2351 ne
= create_var (*ep
, "freeze");
2356 /* Go through an expression's references and assign them to temporary
2357 variables if they contain functions. This is usually done prior to
2358 front-end scalarization to avoid multiple invocations of functions. */
2361 freeze_references (gfc_expr
*e
)
2367 for (r
=e
->ref
; r
; r
=r
->next
)
2369 if (r
->type
== REF_SUBSTRING
)
2371 if (r
->u
.ss
.start
!= NULL
)
2372 freeze_expr (&r
->u
.ss
.start
);
2374 if (r
->u
.ss
.end
!= NULL
)
2375 freeze_expr (&r
->u
.ss
.end
);
2377 else if (r
->type
== REF_ARRAY
)
2386 for (i
=0; i
<ar
->dimen
; i
++)
2388 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2390 freeze_expr (&ar
->start
[i
]);
2391 freeze_expr (&ar
->end
[i
]);
2392 freeze_expr (&ar
->stride
[i
]);
2394 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2396 freeze_expr (&ar
->start
[i
]);
2402 for (i
=0; i
<ar
->dimen
; i
++)
2403 freeze_expr (&ar
->start
[i
]);
2413 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2416 convert_to_index_kind (gfc_expr
*e
)
2420 gcc_assert (e
!= NULL
);
2422 res
= gfc_copy_expr (e
);
2424 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2426 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2430 ts
.type
= BT_INTEGER
;
2431 ts
.kind
= gfc_index_integer_kind
;
2433 gfc_convert_type_warn (e
, &ts
, 2, 0);
2439 /* Function to create a DO loop including creation of the
2440 iteration variable. gfc_expr are copied.*/
2443 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2444 gfc_namespace
*ns
, char *vname
)
2447 char name
[GFC_MAX_SYMBOL_LEN
+1];
2448 gfc_symtree
*symtree
;
2453 /* Create an expression for the iteration variable. */
2455 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2457 sprintf (name
, "__var_%d_do", var_num
++);
2460 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2463 /* Create the loop variable. */
2465 symbol
= symtree
->n
.sym
;
2466 symbol
->ts
.type
= BT_INTEGER
;
2467 symbol
->ts
.kind
= gfc_index_integer_kind
;
2468 symbol
->attr
.flavor
= FL_VARIABLE
;
2469 symbol
->attr
.referenced
= 1;
2470 symbol
->attr
.dimension
= 0;
2471 symbol
->attr
.fe_temp
= 1;
2472 gfc_commit_symbol (symbol
);
2474 i
= gfc_get_expr ();
2475 i
->expr_type
= EXPR_VARIABLE
;
2479 i
->symtree
= symtree
;
2481 /* ... and the nested DO statements. */
2482 n
= XCNEW (gfc_code
);
2485 n
->ext
.iterator
= gfc_get_iterator ();
2486 n
->ext
.iterator
->var
= i
;
2487 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2488 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2490 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2492 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2495 n2
= XCNEW (gfc_code
);
2503 /* Get the upper bound of the DO loops for matmul along a dimension. This
2507 get_size_m1 (gfc_expr
*e
, int dimen
)
2512 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2514 res
= gfc_get_constant_expr (BT_INTEGER
,
2515 gfc_index_integer_kind
, &e
->where
);
2516 mpz_sub_ui (res
->value
.integer
, size
, 1);
2521 res
= get_operand (INTRINSIC_MINUS
,
2522 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2523 gfc_get_int_expr (gfc_index_integer_kind
,
2525 gfc_simplify_expr (res
, 0);
2531 /* Function to return a scalarized expression. It is assumed that indices are
2532 zero based to make generation of DO loops easier. A zero as index will
2533 access the first element along a dimension. Single element references will
2534 be skipped. A NULL as an expression will be replaced by a full reference.
2535 This assumes that the index loops have gfc_index_integer_kind, and that all
2536 references have been frozen. */
2539 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2548 e
= gfc_copy_expr(e_in
);
2552 ar
= gfc_find_array_ref (e
);
2554 /* We scalarize count_index variables, reducing the rank by count_index. */
2556 e
->rank
= rank
- count_index
;
2558 was_fullref
= ar
->type
== AR_FULL
;
2561 ar
->type
= AR_ELEMENT
;
2563 ar
->type
= AR_SECTION
;
2565 /* Loop over the indices. For each index, create the expression
2566 index * stride + lbound(e, dim). */
2569 for (i
=0; i
< ar
->dimen
; i
++)
2571 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2573 if (index
[i_index
] != NULL
)
2575 gfc_expr
*lbound
, *nindex
;
2578 loopvar
= gfc_copy_expr (index
[i_index
]);
2584 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2585 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2589 ts
.type
= BT_INTEGER
;
2590 ts
.kind
= gfc_index_integer_kind
;
2591 gfc_convert_type (tmp
, &ts
, 2);
2593 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2598 /* Calculate the lower bound of the expression. */
2601 lbound
= gfc_copy_expr (ar
->start
[i
]);
2602 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2606 ts
.type
= BT_INTEGER
;
2607 ts
.kind
= gfc_index_integer_kind
;
2608 gfc_convert_type (lbound
, &ts
, 2);
2617 lbound_e
= gfc_copy_expr (e_in
);
2619 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2620 if (ref
->type
== REF_ARRAY
2621 && (ref
->u
.ar
.type
== AR_FULL
2622 || ref
->u
.ar
.type
== AR_SECTION
))
2627 gfc_free_ref_list (ref
->next
);
2633 /* Look at full individual sections, like a(:). The first index
2634 is the lbound of a full ref. */
2640 for (j
= 0; j
< ar
->dimen
; j
++)
2642 gfc_free_expr (ar
->start
[j
]);
2643 ar
->start
[j
] = NULL
;
2644 gfc_free_expr (ar
->end
[j
]);
2646 gfc_free_expr (ar
->stride
[j
]);
2647 ar
->stride
[j
] = NULL
;
2650 /* We have to get rid of the shape, if there is one. Do
2651 so by freeing it and calling gfc_resolve to rebuild
2652 it, if necessary. */
2654 if (lbound_e
->shape
)
2655 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2657 lbound_e
->rank
= ar
->dimen
;
2658 gfc_resolve_expr (lbound_e
);
2660 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2662 gfc_free_expr (lbound_e
);
2665 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2667 gfc_free_expr (ar
->start
[i
]);
2668 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2670 gfc_free_expr (ar
->end
[i
]);
2672 gfc_free_expr (ar
->stride
[i
]);
2673 ar
->stride
[i
] = NULL
;
2674 gfc_simplify_expr (ar
->start
[i
], 0);
2676 else if (was_fullref
)
2678 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2687 /* Helper function to check for a dimen vector as subscript. */
2690 has_dimen_vector_ref (gfc_expr
*e
)
2695 ar
= gfc_find_array_ref (e
);
2697 if (ar
->type
== AR_FULL
)
2700 for (i
=0; i
<ar
->dimen
; i
++)
2701 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2707 /* If handed an expression of the form
2711 check if A can be handled by matmul and return if there is an uneven number
2712 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2713 otherwise. The caller has to check for the correct rank. */
2716 check_conjg_variable (gfc_expr
*e
, bool *conjg
)
2722 if (e
->expr_type
== EXPR_VARIABLE
)
2724 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2727 else if (e
->expr_type
== EXPR_FUNCTION
)
2729 if (e
->value
.function
.isym
== NULL
)
2732 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2739 e
= e
->value
.function
.actual
->expr
;
2746 /* Inline assignments of the form c = matmul(a,b).
2747 Handle only the cases currently where b and c are rank-two arrays.
2749 This basically translates the code to
2755 do k=0, size(a, 2)-1
2756 do i=0, size(a, 1)-1
2757 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2758 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2759 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2760 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2769 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2770 void *data ATTRIBUTE_UNUSED
)
2773 gfc_expr
*expr1
, *expr2
;
2774 gfc_expr
*matrix_a
, *matrix_b
;
2775 gfc_actual_arglist
*a
, *b
;
2776 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2778 gfc_expr
*u1
, *u2
, *u3
;
2780 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2782 gfc_expr
*var_1
, *var_2
, *var_3
;
2785 gfc_intrinsic_op op_times
, op_plus
;
2786 enum matrix_case m_case
;
2788 gfc_code
*if_limit
= NULL
;
2789 gfc_code
**next_code_point
;
2790 bool conjg_a
, conjg_b
;
2792 if (co
->op
!= EXEC_ASSIGN
)
2797 if (expr2
->expr_type
!= EXPR_FUNCTION
2798 || expr2
->value
.function
.isym
== NULL
2799 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2803 inserted_block
= NULL
;
2804 changed_statement
= NULL
;
2806 a
= expr2
->value
.function
.actual
;
2807 matrix_a
= check_conjg_variable (a
->expr
, &conjg_a
);
2808 if (matrix_a
== NULL
)
2812 matrix_b
= check_conjg_variable (b
->expr
, &conjg_b
);
2813 if (matrix_b
== NULL
)
2816 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2817 || has_dimen_vector_ref (matrix_b
))
2820 /* We do not handle data dependencies yet. */
2821 if (gfc_check_dependency (expr1
, matrix_a
, true)
2822 || gfc_check_dependency (expr1
, matrix_b
, true))
2825 if (matrix_a
->rank
== 2)
2826 m_case
= matrix_b
->rank
== 1 ? A2B1
: A2B2
;
2831 ns
= insert_block ();
2833 /* Assign the type of the zero expression for initializing the resulting
2834 array, and the expression (+ and * for real, integer and complex;
2835 .and. and .or for logical. */
2837 switch(expr1
->ts
.type
)
2840 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2841 op_times
= INTRINSIC_TIMES
;
2842 op_plus
= INTRINSIC_PLUS
;
2846 op_times
= INTRINSIC_AND
;
2847 op_plus
= INTRINSIC_OR
;
2848 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2852 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2854 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2855 op_times
= INTRINSIC_TIMES
;
2856 op_plus
= INTRINSIC_PLUS
;
2860 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2862 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2863 op_times
= INTRINSIC_TIMES
;
2864 op_plus
= INTRINSIC_PLUS
;
2872 current_code
= &ns
->code
;
2874 /* Freeze the references, keeping track of how many temporary variables were
2877 freeze_references (matrix_a
);
2878 freeze_references (matrix_b
);
2879 freeze_references (expr1
);
2882 next_code_point
= current_code
;
2885 next_code_point
= &ns
->code
;
2886 for (i
=0; i
<n_vars
; i
++)
2887 next_code_point
= &(*next_code_point
)->next
;
2890 /* Take care of the inline flag. If the limit check evaluates to a
2891 constant, dead code elimination will eliminate the unneeded branch. */
2893 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2895 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2897 /* Insert the original statement into the else branch. */
2898 if_limit
->block
->block
->next
= co
;
2901 /* ... and the new ones go into the original one. */
2902 *next_code_point
= if_limit
;
2903 next_code_point
= &if_limit
->block
->next
;
2906 assign_zero
= XCNEW (gfc_code
);
2907 assign_zero
->op
= EXEC_ASSIGN
;
2908 assign_zero
->loc
= co
->loc
;
2909 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2910 assign_zero
->expr2
= zero_e
;
2912 /* Handle the reallocation, if needed. */
2913 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2915 gfc_code
*lhs_alloc
;
2917 /* Only need to check a single dimension for the A2B2 case for
2918 bounds checking, the rest will be allocated. */
2920 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2925 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2926 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2927 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2928 "in MATMUL intrinsic: Is %ld, should be %ld");
2929 *next_code_point
= test
;
2930 next_code_point
= &test
->next
;
2934 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
2936 *next_code_point
= lhs_alloc
;
2937 next_code_point
= &lhs_alloc
->next
;
2940 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2943 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
2945 if (m_case
== A2B2
|| m_case
== A2B1
)
2947 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2948 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2949 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2950 "in MATMUL intrinsic: Is %ld, should be %ld");
2951 *next_code_point
= test
;
2952 next_code_point
= &test
->next
;
2954 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2955 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2958 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2959 "MATMUL intrinsic for dimension 1: "
2960 "is %ld, should be %ld");
2961 else if (m_case
== A2B1
)
2962 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2963 "MATMUL intrinsic: "
2964 "is %ld, should be %ld");
2967 *next_code_point
= test
;
2968 next_code_point
= &test
->next
;
2970 else if (m_case
== A1B2
)
2972 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2973 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2974 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
2975 "in MATMUL intrinsic: Is %ld, should be %ld");
2976 *next_code_point
= test
;
2977 next_code_point
= &test
->next
;
2979 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2980 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2982 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
2983 "MATMUL intrinsic: "
2984 "is %ld, should be %ld");
2986 *next_code_point
= test
;
2987 next_code_point
= &test
->next
;
2992 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
2993 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2994 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
2995 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
2997 *next_code_point
= test
;
2998 next_code_point
= &test
->next
;
3002 *next_code_point
= assign_zero
;
3004 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3006 assign_matmul
= XCNEW (gfc_code
);
3007 assign_matmul
->op
= EXEC_ASSIGN
;
3008 assign_matmul
->loc
= co
->loc
;
3010 /* Get the bounds for the loops, create them and create the scalarized
3016 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3018 u1
= get_size_m1 (matrix_b
, 2);
3019 u2
= get_size_m1 (matrix_a
, 2);
3020 u3
= get_size_m1 (matrix_a
, 1);
3022 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3023 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3024 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3026 do_1
->block
->next
= do_2
;
3027 do_2
->block
->next
= do_3
;
3028 do_3
->block
->next
= assign_matmul
;
3030 var_1
= do_1
->ext
.iterator
->var
;
3031 var_2
= do_2
->ext
.iterator
->var
;
3032 var_3
= do_3
->ext
.iterator
->var
;
3036 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3040 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3044 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3049 u1
= get_size_m1 (matrix_b
, 1);
3050 u2
= get_size_m1 (matrix_a
, 1);
3052 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3053 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3055 do_1
->block
->next
= do_2
;
3056 do_2
->block
->next
= assign_matmul
;
3058 var_1
= do_1
->ext
.iterator
->var
;
3059 var_2
= do_2
->ext
.iterator
->var
;
3062 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3066 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3069 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3074 u1
= get_size_m1 (matrix_b
, 2);
3075 u2
= get_size_m1 (matrix_a
, 1);
3077 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3078 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3080 do_1
->block
->next
= do_2
;
3081 do_2
->block
->next
= assign_matmul
;
3083 var_1
= do_1
->ext
.iterator
->var
;
3084 var_2
= do_2
->ext
.iterator
->var
;
3087 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3090 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3094 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3103 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3104 matrix_a
->where
, 1, ascalar
);
3107 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3108 matrix_b
->where
, 1, bscalar
);
3110 /* First loop comes after the zero assignment. */
3111 assign_zero
->next
= do_1
;
3113 /* Build the assignment expression in the loop. */
3114 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3116 mult
= get_operand (op_times
, ascalar
, bscalar
);
3117 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3119 /* If we don't want to keep the original statement around in
3120 the else branch, we can free it. */
3122 if (if_limit
== NULL
)
3123 gfc_free_statements(co
);
3127 gfc_free_expr (zero
);
3132 #define WALK_SUBEXPR(NODE) \
3135 result = gfc_expr_walker (&(NODE), exprfn, data); \
3140 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3142 /* Walk expression *E, calling EXPRFN on each expression in it. */
3145 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3149 int walk_subtrees
= 1;
3150 gfc_actual_arglist
*a
;
3154 int result
= exprfn (e
, &walk_subtrees
, data
);
3158 switch ((*e
)->expr_type
)
3161 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3162 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3165 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3166 WALK_SUBEXPR (a
->expr
);
3170 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3171 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3172 WALK_SUBEXPR (a
->expr
);
3175 case EXPR_STRUCTURE
:
3177 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3178 c
= gfc_constructor_next (c
))
3180 if (c
->iterator
== NULL
)
3181 WALK_SUBEXPR (c
->expr
);
3185 WALK_SUBEXPR (c
->expr
);
3187 WALK_SUBEXPR (c
->iterator
->var
);
3188 WALK_SUBEXPR (c
->iterator
->start
);
3189 WALK_SUBEXPR (c
->iterator
->end
);
3190 WALK_SUBEXPR (c
->iterator
->step
);
3194 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3197 /* Fall through to the variable case in order to walk the
3200 case EXPR_SUBSTRING
:
3202 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3211 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3213 for (i
=0; i
< ar
->dimen
; i
++)
3215 WALK_SUBEXPR (ar
->start
[i
]);
3216 WALK_SUBEXPR (ar
->end
[i
]);
3217 WALK_SUBEXPR (ar
->stride
[i
]);
3224 WALK_SUBEXPR (r
->u
.ss
.start
);
3225 WALK_SUBEXPR (r
->u
.ss
.end
);
3241 #define WALK_SUBCODE(NODE) \
3244 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3250 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3251 on each expression in it. If any of the hooks returns non-zero, that
3252 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3253 no subcodes or subexpressions are traversed. */
3256 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3259 for (; *c
; c
= &(*c
)->next
)
3261 int walk_subtrees
= 1;
3262 int result
= codefn (c
, &walk_subtrees
, data
);
3269 gfc_actual_arglist
*a
;
3271 gfc_association_list
*alist
;
3272 bool saved_in_omp_workshare
;
3274 /* There might be statement insertions before the current code,
3275 which must not affect the expression walker. */
3278 saved_in_omp_workshare
= in_omp_workshare
;
3284 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3285 if (co
->ext
.block
.assoc
)
3287 bool saved_in_assoc_list
= in_assoc_list
;
3289 in_assoc_list
= true;
3290 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3291 WALK_SUBEXPR (alist
->target
);
3293 in_assoc_list
= saved_in_assoc_list
;
3300 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3301 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3302 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3303 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3307 case EXEC_ASSIGN_CALL
:
3308 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3309 WALK_SUBEXPR (a
->expr
);
3313 WALK_SUBEXPR (co
->expr1
);
3314 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3315 WALK_SUBEXPR (a
->expr
);
3319 WALK_SUBEXPR (co
->expr1
);
3320 for (b
= co
->block
; b
; b
= b
->block
)
3323 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3325 WALK_SUBEXPR (cp
->low
);
3326 WALK_SUBEXPR (cp
->high
);
3328 WALK_SUBCODE (b
->next
);
3333 case EXEC_DEALLOCATE
:
3336 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3337 WALK_SUBEXPR (a
->expr
);
3342 case EXEC_DO_CONCURRENT
:
3344 gfc_forall_iterator
*fa
;
3345 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3347 WALK_SUBEXPR (fa
->var
);
3348 WALK_SUBEXPR (fa
->start
);
3349 WALK_SUBEXPR (fa
->end
);
3350 WALK_SUBEXPR (fa
->stride
);
3352 if (co
->op
== EXEC_FORALL
)
3358 WALK_SUBEXPR (co
->ext
.open
->unit
);
3359 WALK_SUBEXPR (co
->ext
.open
->file
);
3360 WALK_SUBEXPR (co
->ext
.open
->status
);
3361 WALK_SUBEXPR (co
->ext
.open
->access
);
3362 WALK_SUBEXPR (co
->ext
.open
->form
);
3363 WALK_SUBEXPR (co
->ext
.open
->recl
);
3364 WALK_SUBEXPR (co
->ext
.open
->blank
);
3365 WALK_SUBEXPR (co
->ext
.open
->position
);
3366 WALK_SUBEXPR (co
->ext
.open
->action
);
3367 WALK_SUBEXPR (co
->ext
.open
->delim
);
3368 WALK_SUBEXPR (co
->ext
.open
->pad
);
3369 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3370 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3371 WALK_SUBEXPR (co
->ext
.open
->convert
);
3372 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3373 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3374 WALK_SUBEXPR (co
->ext
.open
->round
);
3375 WALK_SUBEXPR (co
->ext
.open
->sign
);
3376 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3377 WALK_SUBEXPR (co
->ext
.open
->id
);
3378 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3382 WALK_SUBEXPR (co
->ext
.close
->unit
);
3383 WALK_SUBEXPR (co
->ext
.close
->status
);
3384 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3385 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3388 case EXEC_BACKSPACE
:
3392 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3393 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3394 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3398 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3399 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3400 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3401 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3402 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3403 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3404 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3405 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3406 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3407 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3408 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3409 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3410 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3411 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3412 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3413 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3414 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3415 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3416 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3417 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3418 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3419 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3420 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3421 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3422 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3423 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3424 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3425 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3426 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3427 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3428 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3429 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3430 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3431 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3432 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3433 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3437 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3438 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3439 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3440 WALK_SUBEXPR (co
->ext
.wait
->id
);
3445 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3446 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3447 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3448 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3449 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3450 WALK_SUBEXPR (co
->ext
.dt
->size
);
3451 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3452 WALK_SUBEXPR (co
->ext
.dt
->id
);
3453 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3454 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3455 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3456 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3457 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3458 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3459 WALK_SUBEXPR (co
->ext
.dt
->round
);
3460 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3461 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3464 case EXEC_OMP_PARALLEL
:
3465 case EXEC_OMP_PARALLEL_DO
:
3466 case EXEC_OMP_PARALLEL_DO_SIMD
:
3467 case EXEC_OMP_PARALLEL_SECTIONS
:
3469 in_omp_workshare
= false;
3471 /* This goto serves as a shortcut to avoid code
3472 duplication or a larger if or switch statement. */
3473 goto check_omp_clauses
;
3475 case EXEC_OMP_WORKSHARE
:
3476 case EXEC_OMP_PARALLEL_WORKSHARE
:
3478 in_omp_workshare
= true;
3482 case EXEC_OMP_DISTRIBUTE
:
3483 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3484 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3485 case EXEC_OMP_DISTRIBUTE_SIMD
:
3487 case EXEC_OMP_DO_SIMD
:
3488 case EXEC_OMP_SECTIONS
:
3489 case EXEC_OMP_SINGLE
:
3490 case EXEC_OMP_END_SINGLE
:
3492 case EXEC_OMP_TARGET
:
3493 case EXEC_OMP_TARGET_DATA
:
3494 case EXEC_OMP_TARGET_TEAMS
:
3495 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3496 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3497 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3498 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3499 case EXEC_OMP_TARGET_UPDATE
:
3501 case EXEC_OMP_TEAMS
:
3502 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3503 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3504 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3505 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3507 /* Come to this label only from the
3508 EXEC_OMP_PARALLEL_* cases above. */
3512 if (co
->ext
.omp_clauses
)
3514 gfc_omp_namelist
*n
;
3515 static int list_types
[]
3516 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3517 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3519 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3520 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3521 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3522 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3523 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3524 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3525 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3526 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3527 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3528 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3530 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3532 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3534 WALK_SUBEXPR (n
->expr
);
3541 WALK_SUBEXPR (co
->expr1
);
3542 WALK_SUBEXPR (co
->expr2
);
3543 WALK_SUBEXPR (co
->expr3
);
3544 WALK_SUBEXPR (co
->expr4
);
3545 for (b
= co
->block
; b
; b
= b
->block
)
3547 WALK_SUBEXPR (b
->expr1
);
3548 WALK_SUBEXPR (b
->expr2
);
3549 WALK_SUBCODE (b
->next
);
3552 if (co
->op
== EXEC_FORALL
)
3555 if (co
->op
== EXEC_DO
)
3558 in_omp_workshare
= saved_in_omp_workshare
;