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 op1
= e
->value
.op
.op1
;
1247 op2
= e
->value
.op
.op2
;
1249 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1250 scalar_first
= false;
1251 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1253 scalar_first
= true;
1254 op1
= e
->value
.op
.op2
;
1255 op2
= e
->value
.op
.op1
;
1260 if (op2
->ts
.type
== BT_CHARACTER
)
1263 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1265 oldbase
= op1
->value
.constructor
;
1267 e
->expr_type
= EXPR_ARRAY
;
1269 for (c
= gfc_constructor_first (oldbase
); c
;
1270 c
= gfc_constructor_next (c
))
1272 new_expr
= gfc_get_expr ();
1273 new_expr
->ts
= e
->ts
;
1274 new_expr
->expr_type
= EXPR_OP
;
1275 new_expr
->rank
= c
->expr
->rank
;
1276 new_expr
->where
= c
->where
;
1277 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1281 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1282 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1286 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1287 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1290 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1291 new_c
->iterator
= c
->iterator
;
1295 gfc_free_expr (op1
);
1296 gfc_free_expr (op2
);
1297 gfc_free_expr (scalar
);
1299 e
->value
.constructor
= newbase
;
1303 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1304 2**k into ishift(1,k) */
1307 optimize_power (gfc_expr
*e
)
1309 gfc_expr
*op1
, *op2
;
1310 gfc_expr
*iand
, *ishft
;
1312 if (e
->ts
.type
!= BT_INTEGER
)
1315 op1
= e
->value
.op
.op1
;
1317 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1320 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1322 gfc_free_expr (op1
);
1324 op2
= e
->value
.op
.op2
;
1329 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1330 "_internal_iand", e
->where
, 2, op2
,
1331 gfc_get_int_expr (e
->ts
.kind
,
1334 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1335 "_internal_ishft", e
->where
, 2, iand
,
1336 gfc_get_int_expr (e
->ts
.kind
,
1339 e
->value
.op
.op
= INTRINSIC_MINUS
;
1340 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1341 e
->value
.op
.op2
= ishft
;
1344 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1346 gfc_free_expr (op1
);
1348 op2
= e
->value
.op
.op2
;
1352 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1353 "_internal_ishft", e
->where
, 2,
1354 gfc_get_int_expr (e
->ts
.kind
,
1361 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1363 op2
= e
->value
.op
.op2
;
1367 gfc_free_expr (op1
);
1368 gfc_free_expr (op2
);
1370 e
->expr_type
= EXPR_CONSTANT
;
1371 e
->value
.op
.op1
= NULL
;
1372 e
->value
.op
.op2
= NULL
;
1373 mpz_init_set_si (e
->value
.integer
, 1);
1374 /* Typespec and location are still OK. */
1381 /* Recursive optimization of operators. */
1384 optimize_op (gfc_expr
*e
)
1388 gfc_intrinsic_op op
= e
->value
.op
.op
;
1392 /* Only use new-style comparisons. */
1395 case INTRINSIC_EQ_OS
:
1399 case INTRINSIC_GE_OS
:
1403 case INTRINSIC_LE_OS
:
1407 case INTRINSIC_NE_OS
:
1411 case INTRINSIC_GT_OS
:
1415 case INTRINSIC_LT_OS
:
1431 changed
= optimize_comparison (e
, op
);
1434 /* Look at array constructors. */
1435 case INTRINSIC_PLUS
:
1436 case INTRINSIC_MINUS
:
1437 case INTRINSIC_TIMES
:
1438 case INTRINSIC_DIVIDE
:
1439 return combine_array_constructor (e
) || changed
;
1441 case INTRINSIC_POWER
:
1442 return optimize_power (e
);
1453 /* Return true if a constant string contains only blanks. */
1456 is_empty_string (gfc_expr
*e
)
1460 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1463 for (i
=0; i
< e
->value
.character
.length
; i
++)
1465 if (e
->value
.character
.string
[i
] != ' ')
1473 /* Insert a call to the intrinsic len_trim. Use a different name for
1474 the symbol tree so we don't run into trouble when the user has
1475 renamed len_trim for some reason. */
1478 get_len_trim_call (gfc_expr
*str
, int kind
)
1481 gfc_actual_arglist
*actual_arglist
, *next
;
1483 fcn
= gfc_get_expr ();
1484 fcn
->expr_type
= EXPR_FUNCTION
;
1485 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1486 actual_arglist
= gfc_get_actual_arglist ();
1487 actual_arglist
->expr
= str
;
1488 next
= gfc_get_actual_arglist ();
1489 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1490 actual_arglist
->next
= next
;
1492 fcn
->value
.function
.actual
= actual_arglist
;
1493 fcn
->where
= str
->where
;
1494 fcn
->ts
.type
= BT_INTEGER
;
1495 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1497 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1498 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1499 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1500 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1501 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1502 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1503 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1504 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1509 /* Optimize expressions for equality. */
1512 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1514 gfc_expr
*op1
, *op2
;
1518 gfc_actual_arglist
*firstarg
, *secondarg
;
1520 if (e
->expr_type
== EXPR_OP
)
1524 op1
= e
->value
.op
.op1
;
1525 op2
= e
->value
.op
.op2
;
1527 else if (e
->expr_type
== EXPR_FUNCTION
)
1529 /* One of the lexical comparison functions. */
1530 firstarg
= e
->value
.function
.actual
;
1531 secondarg
= firstarg
->next
;
1532 op1
= firstarg
->expr
;
1533 op2
= secondarg
->expr
;
1538 /* Strip off unneeded TRIM calls from string comparisons. */
1540 change
= remove_trim (op1
);
1542 if (remove_trim (op2
))
1545 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1546 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1547 handles them well). However, there are also cases that need a non-scalar
1548 argument. For example the any intrinsic. See PR 45380. */
1552 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1554 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1555 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1557 bool empty_op1
, empty_op2
;
1558 empty_op1
= is_empty_string (op1
);
1559 empty_op2
= is_empty_string (op2
);
1561 if (empty_op1
|| empty_op2
)
1567 /* This can only happen when an error for comparing
1568 characters of different kinds has already been issued. */
1569 if (empty_op1
&& empty_op2
)
1572 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1573 str
= empty_op1
? op2
: op1
;
1575 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1579 gfc_free_expr (op1
);
1581 gfc_free_expr (op2
);
1585 e
->value
.op
.op1
= fcn
;
1586 e
->value
.op
.op2
= zero
;
1591 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1593 if (flag_finite_math_only
1594 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1595 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1597 eq
= gfc_dep_compare_expr (op1
, op2
);
1600 /* Replace A // B < A // C with B < C, and A // B < C // B
1602 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1603 && op1
->expr_type
== EXPR_OP
1604 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1605 && op2
->expr_type
== EXPR_OP
1606 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1608 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1609 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1610 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1611 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1613 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1615 /* Watch out for 'A ' // x vs. 'A' // x. */
1617 if (op1_left
->expr_type
== EXPR_CONSTANT
1618 && op2_left
->expr_type
== EXPR_CONSTANT
1619 && op1_left
->value
.character
.length
1620 != op2_left
->value
.character
.length
)
1628 firstarg
->expr
= op1_right
;
1629 secondarg
->expr
= op2_right
;
1633 e
->value
.op
.op1
= op1_right
;
1634 e
->value
.op
.op2
= op2_right
;
1636 optimize_comparison (e
, op
);
1640 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1646 firstarg
->expr
= op1_left
;
1647 secondarg
->expr
= op2_left
;
1651 e
->value
.op
.op1
= op1_left
;
1652 e
->value
.op
.op2
= op2_left
;
1655 optimize_comparison (e
, op
);
1662 /* eq can only be -1, 0 or 1 at this point. */
1690 gfc_internal_error ("illegal OP in optimize_comparison");
1694 /* Replace the expression by a constant expression. The typespec
1695 and where remains the way it is. */
1698 e
->expr_type
= EXPR_CONSTANT
;
1699 e
->value
.logical
= result
;
1707 /* Optimize a trim function by replacing it with an equivalent substring
1708 involving a call to len_trim. This only works for expressions where
1709 variables are trimmed. Return true if anything was modified. */
1712 optimize_trim (gfc_expr
*e
)
1717 gfc_ref
**rr
= NULL
;
1719 /* Don't do this optimization within an argument list, because
1720 otherwise aliasing issues may occur. */
1722 if (count_arglist
!= 1)
1725 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1726 || e
->value
.function
.isym
== NULL
1727 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1730 a
= e
->value
.function
.actual
->expr
;
1732 if (a
->expr_type
!= EXPR_VARIABLE
)
1735 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1737 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1740 /* Follow all references to find the correct place to put the newly
1741 created reference. FIXME: Also handle substring references and
1742 array references. Array references cause strange regressions at
1747 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1749 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1754 strip_function_call (e
);
1759 /* Create the reference. */
1761 ref
= gfc_get_ref ();
1762 ref
->type
= REF_SUBSTRING
;
1764 /* Set the start of the reference. */
1766 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1768 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1770 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1772 /* Set the end of the reference to the call to len_trim. */
1774 ref
->u
.ss
.end
= fcn
;
1775 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1780 /* Optimize minloc(b), where b is rank 1 array, into
1781 (/ minloc(b, dim=1) /), and similarly for maxloc,
1782 as the latter forms are expanded inline. */
1785 optimize_minmaxloc (gfc_expr
**e
)
1788 gfc_actual_arglist
*a
;
1792 || fn
->value
.function
.actual
== NULL
1793 || fn
->value
.function
.actual
->expr
== NULL
1794 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1797 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1798 (*e
)->shape
= fn
->shape
;
1801 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1803 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1804 strcpy (name
, fn
->value
.function
.name
);
1805 p
= strstr (name
, "loc0");
1807 fn
->value
.function
.name
= gfc_get_string (name
);
1808 if (fn
->value
.function
.actual
->next
)
1810 a
= fn
->value
.function
.actual
->next
;
1811 gcc_assert (a
->expr
== NULL
);
1815 a
= gfc_get_actual_arglist ();
1816 fn
->value
.function
.actual
->next
= a
;
1818 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1820 mpz_set_ui (a
->expr
->value
.integer
, 1);
1823 /* Callback function for code checking that we do not pass a DO variable to an
1824 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1827 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1828 void *data ATTRIBUTE_UNUSED
)
1832 gfc_formal_arglist
*f
;
1833 gfc_actual_arglist
*a
;
1838 /* If the doloop_list grew, we have to truncate it here. */
1840 if ((unsigned) doloop_level
< doloop_list
.length())
1841 doloop_list
.truncate (doloop_level
);
1847 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1848 doloop_list
.safe_push (co
);
1850 doloop_list
.safe_push ((gfc_code
*) NULL
);
1855 if (co
->resolved_sym
== NULL
)
1858 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1860 /* Withot a formal arglist, there is only unknown INTENT,
1861 which we don't check for. */
1869 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1876 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1878 if (a
->expr
&& a
->expr
->symtree
1879 && a
->expr
->symtree
->n
.sym
== do_sym
)
1881 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1882 gfc_error_now_1 ("Variable '%s' at %L set to undefined "
1883 "value inside loop beginning at %L as "
1884 "INTENT(OUT) argument to subroutine '%s'",
1885 do_sym
->name
, &a
->expr
->where
,
1886 &doloop_list
[i
]->loc
,
1887 co
->symtree
->n
.sym
->name
);
1888 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1889 gfc_error_now_1 ("Variable '%s' at %L not definable inside "
1890 "loop beginning at %L as INTENT(INOUT) "
1891 "argument to subroutine '%s'",
1892 do_sym
->name
, &a
->expr
->where
,
1893 &doloop_list
[i
]->loc
,
1894 co
->symtree
->n
.sym
->name
);
1908 /* Callback function for functions checking that we do not pass a DO variable
1909 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1912 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1913 void *data ATTRIBUTE_UNUSED
)
1915 gfc_formal_arglist
*f
;
1916 gfc_actual_arglist
*a
;
1922 if (expr
->expr_type
!= EXPR_FUNCTION
)
1925 /* Intrinsic functions don't modify their arguments. */
1927 if (expr
->value
.function
.isym
)
1930 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1932 /* Without a formal arglist, there is only unknown INTENT,
1933 which we don't check for. */
1937 a
= expr
->value
.function
.actual
;
1941 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1948 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1950 if (a
->expr
&& a
->expr
->symtree
1951 && a
->expr
->symtree
->n
.sym
== do_sym
)
1953 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1954 gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
1955 "inside loop beginning at %L as INTENT(OUT) "
1956 "argument to function '%s'", do_sym
->name
,
1957 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1958 expr
->symtree
->n
.sym
->name
);
1959 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1960 gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
1961 " beginning at %L as INTENT(INOUT) argument to"
1962 " function '%s'", do_sym
->name
,
1963 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1964 expr
->symtree
->n
.sym
->name
);
1975 doloop_warn (gfc_namespace
*ns
)
1977 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1980 /* This selction deals with inlining calls to MATMUL. */
1982 /* Auxiliary function to build and simplify an array inquiry function.
1983 dim is zero-based. */
1986 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
1989 gfc_expr
*dim_arg
, *kind
;
1995 case GFC_ISYM_LBOUND
:
1996 name
= "_gfortran_lbound";
1999 case GFC_ISYM_UBOUND
:
2000 name
= "_gfortran_ubound";
2004 name
= "_gfortran_size";
2011 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2012 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2013 gfc_index_integer_kind
);
2015 ec
= gfc_copy_expr (e
);
2016 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2018 gfc_simplify_expr (fcn
, 0);
2022 /* Builds a logical expression. */
2025 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2030 ts
.type
= BT_LOGICAL
;
2031 ts
.kind
= gfc_default_logical_kind
;
2032 res
= gfc_get_expr ();
2033 res
->where
= e1
->where
;
2034 res
->expr_type
= EXPR_OP
;
2035 res
->value
.op
.op
= op
;
2036 res
->value
.op
.op1
= e1
;
2037 res
->value
.op
.op2
= e2
;
2044 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2045 compatible typespecs. */
2048 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2052 res
= gfc_get_expr ();
2054 res
->where
= e1
->where
;
2055 res
->expr_type
= EXPR_OP
;
2056 res
->value
.op
.op
= op
;
2057 res
->value
.op
.op1
= e1
;
2058 res
->value
.op
.op2
= e2
;
2059 gfc_simplify_expr (res
, 0);
2063 /* Generate the IF statement for a runtime check if we want to do inlining or
2064 not - putting in the code for both branches and putting it into the syntax
2065 tree is the caller's responsibility. For fixed array sizes, this should be
2066 removed by DCE. Only called for rank-two matrices A and B. */
2069 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2071 gfc_expr
*inline_limit
;
2072 gfc_code
*if_1
, *if_2
, *else_2
;
2073 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2077 gcc_assert (m_case
== A2B2
);
2079 /* Calculation is done in real to avoid integer overflow. */
2081 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2083 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2085 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2088 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2089 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2090 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2094 ts
.kind
= gfc_default_real_kind
;
2095 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2096 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2097 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2099 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2100 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2102 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2103 gfc_simplify_expr (cond
, 0);
2105 else_2
= XCNEW (gfc_code
);
2106 else_2
->op
= EXEC_IF
;
2107 else_2
->loc
= a
->where
;
2109 if_2
= XCNEW (gfc_code
);
2112 if_2
->loc
= a
->where
;
2113 if_2
->block
= else_2
;
2115 if_1
= XCNEW (gfc_code
);
2118 if_1
->loc
= a
->where
;
2124 /* Insert code to issue a runtime error if the expressions are not equal. */
2127 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2130 gfc_code
*if_1
, *if_2
;
2132 gfc_actual_arglist
*a1
, *a2
, *a3
;
2134 gcc_assert (e1
->where
.lb
);
2135 /* Build the call to runtime_error. */
2136 c
= XCNEW (gfc_code
);
2140 /* Get a null-terminated message string. */
2142 a1
= gfc_get_actual_arglist ();
2143 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2144 msg
, strlen(msg
)+1);
2147 /* Pass the value of the first expression. */
2148 a2
= gfc_get_actual_arglist ();
2149 a2
->expr
= gfc_copy_expr (e1
);
2152 /* Pass the value of the second expression. */
2153 a3
= gfc_get_actual_arglist ();
2154 a3
->expr
= gfc_copy_expr (e2
);
2157 gfc_check_fe_runtime_error (c
->ext
.actual
);
2158 gfc_resolve_fe_runtime_error (c
);
2160 if_2
= XCNEW (gfc_code
);
2162 if_2
->loc
= e1
->where
;
2165 if_1
= XCNEW (gfc_code
);
2168 if_1
->loc
= e1
->where
;
2170 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2171 gfc_simplify_expr (cond
, 0);
2177 /* Handle matrix reallocation. Caller is responsible to insert into
2180 For the two-dimensional case, build
2182 if (allocated(c)) then
2183 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2185 allocate (c(size(a,1), size(b,2)))
2188 allocate (c(size(a,1),size(b,2)))
2191 and for the other cases correspondingly.
2195 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2196 enum matrix_case m_case
)
2199 gfc_expr
*allocated
, *alloc_expr
;
2200 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2201 gfc_code
*else_alloc
;
2202 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2204 gfc_expr
*cond
, *ne1
, *ne2
;
2206 if (warn_realloc_lhs
)
2207 gfc_warning (OPT_Wrealloc_lhs
,
2208 "Code for reallocating the allocatable array at %L will "
2209 "be added", &c
->where
);
2211 alloc_expr
= gfc_copy_expr (c
);
2213 ar
= gfc_find_array_ref (alloc_expr
);
2214 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2216 /* c comes in as a full ref. Change it into a copy and make it into an
2217 element ref so it has the right form for for ALLOCATE. In the same
2218 switch statement, also generate the size comparison for the secod IF
2221 ar
->type
= AR_ELEMENT
;
2226 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2227 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2228 ne1
= build_logical_expr (INTRINSIC_NE
,
2229 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2230 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2231 ne2
= build_logical_expr (INTRINSIC_NE
,
2232 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2233 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2234 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2238 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2239 cond
= build_logical_expr (INTRINSIC_NE
,
2240 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2241 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2245 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2246 cond
= build_logical_expr (INTRINSIC_NE
,
2247 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2248 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2256 gfc_simplify_expr (cond
, 0);
2258 /* We need two identical allocate statements in two
2259 branches of the IF statement. */
2261 allocate1
= XCNEW (gfc_code
);
2262 allocate1
->op
= EXEC_ALLOCATE
;
2263 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2264 allocate1
->loc
= c
->where
;
2265 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2267 allocate_else
= XCNEW (gfc_code
);
2268 allocate_else
->op
= EXEC_ALLOCATE
;
2269 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2270 allocate_else
->loc
= c
->where
;
2271 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2273 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2274 "_gfortran_allocated", c
->where
,
2275 1, gfc_copy_expr (c
));
2277 deallocate
= XCNEW (gfc_code
);
2278 deallocate
->op
= EXEC_DEALLOCATE
;
2279 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2280 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2281 deallocate
->next
= allocate1
;
2282 deallocate
->loc
= c
->where
;
2284 if_size_2
= XCNEW (gfc_code
);
2285 if_size_2
->op
= EXEC_IF
;
2286 if_size_2
->expr1
= cond
;
2287 if_size_2
->loc
= c
->where
;
2288 if_size_2
->next
= deallocate
;
2290 if_size_1
= XCNEW (gfc_code
);
2291 if_size_1
->op
= EXEC_IF
;
2292 if_size_1
->block
= if_size_2
;
2293 if_size_1
->loc
= c
->where
;
2295 else_alloc
= XCNEW (gfc_code
);
2296 else_alloc
->op
= EXEC_IF
;
2297 else_alloc
->loc
= c
->where
;
2298 else_alloc
->next
= allocate_else
;
2300 if_alloc_2
= XCNEW (gfc_code
);
2301 if_alloc_2
->op
= EXEC_IF
;
2302 if_alloc_2
->expr1
= allocated
;
2303 if_alloc_2
->loc
= c
->where
;
2304 if_alloc_2
->next
= if_size_1
;
2305 if_alloc_2
->block
= else_alloc
;
2307 if_alloc_1
= XCNEW (gfc_code
);
2308 if_alloc_1
->op
= EXEC_IF
;
2309 if_alloc_1
->block
= if_alloc_2
;
2310 if_alloc_1
->loc
= c
->where
;
2315 /* Callback function for has_function_or_op. */
2318 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2319 void *data ATTRIBUTE_UNUSED
)
2324 return (*e
)->expr_type
== EXPR_FUNCTION
2325 || (*e
)->expr_type
== EXPR_OP
;
2328 /* Returns true if the expression contains a function. */
2331 has_function_or_op (gfc_expr
**e
)
2336 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2339 /* Freeze (assign to a temporary variable) a single expression. */
2342 freeze_expr (gfc_expr
**ep
)
2345 if (has_function_or_op (ep
))
2347 ne
= create_var (*ep
, "freeze");
2352 /* Go through an expression's references and assign them to temporary
2353 variables if they contain functions. This is usually done prior to
2354 front-end scalarization to avoid multiple invocations of functions. */
2357 freeze_references (gfc_expr
*e
)
2363 for (r
=e
->ref
; r
; r
=r
->next
)
2365 if (r
->type
== REF_SUBSTRING
)
2367 if (r
->u
.ss
.start
!= NULL
)
2368 freeze_expr (&r
->u
.ss
.start
);
2370 if (r
->u
.ss
.end
!= NULL
)
2371 freeze_expr (&r
->u
.ss
.end
);
2373 else if (r
->type
== REF_ARRAY
)
2382 for (i
=0; i
<ar
->dimen
; i
++)
2384 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2386 freeze_expr (&ar
->start
[i
]);
2387 freeze_expr (&ar
->end
[i
]);
2388 freeze_expr (&ar
->stride
[i
]);
2390 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2392 freeze_expr (&ar
->start
[i
]);
2398 for (i
=0; i
<ar
->dimen
; i
++)
2399 freeze_expr (&ar
->start
[i
]);
2409 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2412 convert_to_index_kind (gfc_expr
*e
)
2416 gcc_assert (e
!= NULL
);
2418 res
= gfc_copy_expr (e
);
2420 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2422 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2426 ts
.type
= BT_INTEGER
;
2427 ts
.kind
= gfc_index_integer_kind
;
2429 gfc_convert_type_warn (e
, &ts
, 2, 0);
2435 /* Function to create a DO loop including creation of the
2436 iteration variable. gfc_expr are copied.*/
2439 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2440 gfc_namespace
*ns
, char *vname
)
2443 char name
[GFC_MAX_SYMBOL_LEN
+1];
2444 gfc_symtree
*symtree
;
2449 /* Create an expression for the iteration variable. */
2451 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2453 sprintf (name
, "__var_%d_do", var_num
++);
2456 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2459 /* Create the loop variable. */
2461 symbol
= symtree
->n
.sym
;
2462 symbol
->ts
.type
= BT_INTEGER
;
2463 symbol
->ts
.kind
= gfc_index_integer_kind
;
2464 symbol
->attr
.flavor
= FL_VARIABLE
;
2465 symbol
->attr
.referenced
= 1;
2466 symbol
->attr
.dimension
= 0;
2467 symbol
->attr
.fe_temp
= 1;
2468 gfc_commit_symbol (symbol
);
2470 i
= gfc_get_expr ();
2471 i
->expr_type
= EXPR_VARIABLE
;
2475 i
->symtree
= symtree
;
2477 /* ... and the nested DO statements. */
2478 n
= XCNEW (gfc_code
);
2481 n
->ext
.iterator
= gfc_get_iterator ();
2482 n
->ext
.iterator
->var
= i
;
2483 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2484 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2486 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2488 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2491 n2
= XCNEW (gfc_code
);
2499 /* Get the upper bound of the DO loops for matmul along a dimension. This
2503 get_size_m1 (gfc_expr
*e
, int dimen
)
2508 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2510 res
= gfc_get_constant_expr (BT_INTEGER
,
2511 gfc_index_integer_kind
, &e
->where
);
2512 mpz_sub_ui (res
->value
.integer
, size
, 1);
2517 res
= get_operand (INTRINSIC_MINUS
,
2518 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2519 gfc_get_int_expr (gfc_index_integer_kind
,
2521 gfc_simplify_expr (res
, 0);
2527 /* Function to return a scalarized expression. It is assumed that indices are
2528 zero based to make generation of DO loops easier. A zero as index will
2529 access the first element along a dimension. Single element references will
2530 be skipped. A NULL as an expression will be replaced by a full reference.
2531 This assumes that the index loops have gfc_index_integer_kind, and that all
2532 references have been frozen. */
2535 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2544 e
= gfc_copy_expr(e_in
);
2548 ar
= gfc_find_array_ref (e
);
2550 /* We scalarize count_index variables, reducing the rank by count_index. */
2552 e
->rank
= rank
- count_index
;
2554 was_fullref
= ar
->type
== AR_FULL
;
2557 ar
->type
= AR_ELEMENT
;
2559 ar
->type
= AR_SECTION
;
2561 /* Loop over the indices. For each index, create the expression
2562 index * stride + lbound(e, dim). */
2565 for (i
=0; i
< ar
->dimen
; i
++)
2567 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2569 if (index
[i_index
] != NULL
)
2571 gfc_expr
*lbound
, *nindex
;
2574 loopvar
= gfc_copy_expr (index
[i_index
]);
2580 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2581 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2585 ts
.type
= BT_INTEGER
;
2586 ts
.kind
= gfc_index_integer_kind
;
2587 gfc_convert_type (tmp
, &ts
, 2);
2589 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2594 /* Calculate the lower bound of the expression. */
2597 lbound
= gfc_copy_expr (ar
->start
[i
]);
2598 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2602 ts
.type
= BT_INTEGER
;
2603 ts
.kind
= gfc_index_integer_kind
;
2604 gfc_convert_type (lbound
, &ts
, 2);
2613 lbound_e
= gfc_copy_expr (e_in
);
2615 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2616 if (ref
->type
== REF_ARRAY
2617 && (ref
->u
.ar
.type
== AR_FULL
2618 || ref
->u
.ar
.type
== AR_SECTION
))
2623 gfc_free_ref_list (ref
->next
);
2629 /* Look at full individual sections, like a(:). The first index
2630 is the lbound of a full ref. */
2636 for (j
= 0; j
< ar
->dimen
; j
++)
2638 gfc_free_expr (ar
->start
[j
]);
2639 ar
->start
[j
] = NULL
;
2640 gfc_free_expr (ar
->end
[j
]);
2642 gfc_free_expr (ar
->stride
[j
]);
2643 ar
->stride
[j
] = NULL
;
2646 /* We have to get rid of the shape, if there is one. Do
2647 so by freeing it and calling gfc_resolve to rebuild
2648 it, if necessary. */
2650 if (lbound_e
->shape
)
2651 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2653 lbound_e
->rank
= ar
->dimen
;
2654 gfc_resolve_expr (lbound_e
);
2656 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2658 gfc_free_expr (lbound_e
);
2661 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2663 gfc_free_expr (ar
->start
[i
]);
2664 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2666 gfc_free_expr (ar
->end
[i
]);
2668 gfc_free_expr (ar
->stride
[i
]);
2669 ar
->stride
[i
] = NULL
;
2670 gfc_simplify_expr (ar
->start
[i
], 0);
2672 else if (was_fullref
)
2674 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2684 /* Inline assignments of the form c = matmul(a,b).
2685 Handle only the cases currently where b and c are rank-two arrays.
2687 This basically translates the code to
2693 do k=0, size(a, 2)-1
2694 do i=0, size(a, 1)-1
2695 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2696 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2697 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2698 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2707 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2708 void *data ATTRIBUTE_UNUSED
)
2711 gfc_expr
*expr1
, *expr2
;
2712 gfc_expr
*matrix_a
, *matrix_b
;
2713 gfc_actual_arglist
*a
, *b
;
2714 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2716 gfc_expr
*u1
, *u2
, *u3
;
2718 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2720 gfc_expr
*var_1
, *var_2
, *var_3
;
2723 gfc_intrinsic_op op_times
, op_plus
;
2724 enum matrix_case m_case
;
2726 gfc_code
*if_limit
= NULL
;
2727 gfc_code
**next_code_point
;
2729 if (co
->op
!= EXEC_ASSIGN
)
2734 if (expr2
->expr_type
!= EXPR_FUNCTION
2735 || expr2
->value
.function
.isym
== NULL
2736 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2740 inserted_block
= NULL
;
2741 changed_statement
= NULL
;
2743 a
= expr2
->value
.function
.actual
;
2748 /* Currently only handling direct variables. Transpose etc. will come
2751 if (matrix_a
->expr_type
!= EXPR_VARIABLE
2752 || matrix_b
->expr_type
!= EXPR_VARIABLE
)
2755 if (matrix_a
->rank
== 2)
2756 m_case
= matrix_b
->rank
== 1 ? A2B1
: A2B2
;
2760 /* We do not handle data dependencies yet. */
2761 if (gfc_check_dependency (expr1
, matrix_a
, true)
2762 || gfc_check_dependency (expr1
, matrix_b
, true))
2765 ns
= insert_block ();
2767 /* Assign the type of the zero expression for initializing the resulting
2768 array, and the expression (+ and * for real, integer and complex;
2769 .and. and .or for logical. */
2771 switch(expr1
->ts
.type
)
2774 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2775 op_times
= INTRINSIC_TIMES
;
2776 op_plus
= INTRINSIC_PLUS
;
2780 op_times
= INTRINSIC_AND
;
2781 op_plus
= INTRINSIC_OR
;
2782 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2786 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2788 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2789 op_times
= INTRINSIC_TIMES
;
2790 op_plus
= INTRINSIC_PLUS
;
2794 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2796 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2797 op_times
= INTRINSIC_TIMES
;
2798 op_plus
= INTRINSIC_PLUS
;
2806 current_code
= &ns
->code
;
2808 /* Freeze the references, keeping track of how many temporary variables were
2811 freeze_references (matrix_a
);
2812 freeze_references (matrix_b
);
2813 freeze_references (expr1
);
2816 next_code_point
= current_code
;
2819 next_code_point
= &ns
->code
;
2820 for (i
=0; i
<n_vars
; i
++)
2821 next_code_point
= &(*next_code_point
)->next
;
2824 /* Take care of the inline flag. If the limit check evaluates to a
2825 constant, dead code elimination will eliminate the unneeded branch. */
2827 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2829 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2831 /* Insert the original statement into the else branch. */
2832 if_limit
->block
->block
->next
= co
;
2835 /* ... and the new ones go into the original one. */
2836 *next_code_point
= if_limit
;
2837 next_code_point
= &if_limit
->block
->next
;
2840 assign_zero
= XCNEW (gfc_code
);
2841 assign_zero
->op
= EXEC_ASSIGN
;
2842 assign_zero
->loc
= co
->loc
;
2843 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2844 assign_zero
->expr2
= zero_e
;
2846 /* Handle the reallocation, if needed. */
2847 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2849 gfc_code
*lhs_alloc
;
2851 /* Only need to check a single dimension for the A2B2 case for
2852 bounds checking, the rest will be allocated. */
2854 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2859 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2860 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2861 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2862 "in MATMUL intrinsic: Is %ld, should be %ld");
2863 *next_code_point
= test
;
2864 next_code_point
= &test
->next
;
2868 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
2870 *next_code_point
= lhs_alloc
;
2871 next_code_point
= &lhs_alloc
->next
;
2874 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2877 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
2879 if (m_case
== A2B2
|| m_case
== A2B1
)
2881 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2882 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2883 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2884 "in MATMUL intrinsic: Is %ld, should be %ld");
2885 *next_code_point
= test
;
2886 next_code_point
= &test
->next
;
2888 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2889 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2892 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2893 "MATMUL intrinsic for dimension 1: "
2894 "is %ld, should be %ld");
2895 else if (m_case
== A2B1
)
2896 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2897 "MATMUL intrinsic: "
2898 "is %ld, should be %ld");
2901 *next_code_point
= test
;
2902 next_code_point
= &test
->next
;
2904 else if (m_case
== A1B2
)
2906 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2907 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2908 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
2909 "in MATMUL intrinsic: Is %ld, should be %ld");
2910 *next_code_point
= test
;
2911 next_code_point
= &test
->next
;
2913 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2914 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2916 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
2917 "MATMUL intrinsic: "
2918 "is %ld, should be %ld");
2920 *next_code_point
= test
;
2921 next_code_point
= &test
->next
;
2926 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
2927 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2928 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
2929 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
2931 *next_code_point
= test
;
2932 next_code_point
= &test
->next
;
2936 *next_code_point
= assign_zero
;
2938 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
2940 assign_matmul
= XCNEW (gfc_code
);
2941 assign_matmul
->op
= EXEC_ASSIGN
;
2942 assign_matmul
->loc
= co
->loc
;
2944 /* Get the bounds for the loops, create them and create the scalarized
2950 inline_limit_check (matrix_a
, matrix_b
, m_case
);
2952 u1
= get_size_m1 (matrix_b
, 2);
2953 u2
= get_size_m1 (matrix_a
, 2);
2954 u3
= get_size_m1 (matrix_a
, 1);
2956 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
2957 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
2958 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
2960 do_1
->block
->next
= do_2
;
2961 do_2
->block
->next
= do_3
;
2962 do_3
->block
->next
= assign_matmul
;
2964 var_1
= do_1
->ext
.iterator
->var
;
2965 var_2
= do_2
->ext
.iterator
->var
;
2966 var_3
= do_3
->ext
.iterator
->var
;
2970 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
2974 ascalar
= scalarized_expr (matrix_a
, list
, 2);
2978 bscalar
= scalarized_expr (matrix_b
, list
, 2);
2983 u1
= get_size_m1 (matrix_b
, 1);
2984 u2
= get_size_m1 (matrix_a
, 1);
2986 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
2987 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
2989 do_1
->block
->next
= do_2
;
2990 do_2
->block
->next
= assign_matmul
;
2992 var_1
= do_1
->ext
.iterator
->var
;
2993 var_2
= do_2
->ext
.iterator
->var
;
2996 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3000 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3003 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3008 u1
= get_size_m1 (matrix_b
, 2);
3009 u2
= get_size_m1 (matrix_a
, 1);
3011 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3012 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3014 do_1
->block
->next
= do_2
;
3015 do_2
->block
->next
= assign_matmul
;
3017 var_1
= do_1
->ext
.iterator
->var
;
3018 var_2
= do_2
->ext
.iterator
->var
;
3021 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3024 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3028 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3036 /* First loop comes after the zero assignment. */
3037 assign_zero
->next
= do_1
;
3039 /* Build the assignment expression in the loop. */
3040 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3042 mult
= get_operand (op_times
, ascalar
, bscalar
);
3043 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3045 /* If we don't want to keep the original statement around in
3046 the else branch, we can free it. */
3048 if (if_limit
== NULL
)
3049 gfc_free_statements(co
);
3053 gfc_free_expr (zero
);
3058 #define WALK_SUBEXPR(NODE) \
3061 result = gfc_expr_walker (&(NODE), exprfn, data); \
3066 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3068 /* Walk expression *E, calling EXPRFN on each expression in it. */
3071 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3075 int walk_subtrees
= 1;
3076 gfc_actual_arglist
*a
;
3080 int result
= exprfn (e
, &walk_subtrees
, data
);
3084 switch ((*e
)->expr_type
)
3087 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3088 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3091 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3092 WALK_SUBEXPR (a
->expr
);
3096 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3097 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3098 WALK_SUBEXPR (a
->expr
);
3101 case EXPR_STRUCTURE
:
3103 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3104 c
= gfc_constructor_next (c
))
3106 if (c
->iterator
== NULL
)
3107 WALK_SUBEXPR (c
->expr
);
3111 WALK_SUBEXPR (c
->expr
);
3113 WALK_SUBEXPR (c
->iterator
->var
);
3114 WALK_SUBEXPR (c
->iterator
->start
);
3115 WALK_SUBEXPR (c
->iterator
->end
);
3116 WALK_SUBEXPR (c
->iterator
->step
);
3120 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3123 /* Fall through to the variable case in order to walk the
3126 case EXPR_SUBSTRING
:
3128 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3137 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3139 for (i
=0; i
< ar
->dimen
; i
++)
3141 WALK_SUBEXPR (ar
->start
[i
]);
3142 WALK_SUBEXPR (ar
->end
[i
]);
3143 WALK_SUBEXPR (ar
->stride
[i
]);
3150 WALK_SUBEXPR (r
->u
.ss
.start
);
3151 WALK_SUBEXPR (r
->u
.ss
.end
);
3167 #define WALK_SUBCODE(NODE) \
3170 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3176 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3177 on each expression in it. If any of the hooks returns non-zero, that
3178 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3179 no subcodes or subexpressions are traversed. */
3182 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3185 for (; *c
; c
= &(*c
)->next
)
3187 int walk_subtrees
= 1;
3188 int result
= codefn (c
, &walk_subtrees
, data
);
3195 gfc_actual_arglist
*a
;
3197 gfc_association_list
*alist
;
3198 bool saved_in_omp_workshare
;
3200 /* There might be statement insertions before the current code,
3201 which must not affect the expression walker. */
3204 saved_in_omp_workshare
= in_omp_workshare
;
3210 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3211 if (co
->ext
.block
.assoc
)
3213 bool saved_in_assoc_list
= in_assoc_list
;
3215 in_assoc_list
= true;
3216 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3217 WALK_SUBEXPR (alist
->target
);
3219 in_assoc_list
= saved_in_assoc_list
;
3226 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3227 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3228 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3229 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3233 case EXEC_ASSIGN_CALL
:
3234 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3235 WALK_SUBEXPR (a
->expr
);
3239 WALK_SUBEXPR (co
->expr1
);
3240 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3241 WALK_SUBEXPR (a
->expr
);
3245 WALK_SUBEXPR (co
->expr1
);
3246 for (b
= co
->block
; b
; b
= b
->block
)
3249 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3251 WALK_SUBEXPR (cp
->low
);
3252 WALK_SUBEXPR (cp
->high
);
3254 WALK_SUBCODE (b
->next
);
3259 case EXEC_DEALLOCATE
:
3262 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3263 WALK_SUBEXPR (a
->expr
);
3268 case EXEC_DO_CONCURRENT
:
3270 gfc_forall_iterator
*fa
;
3271 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3273 WALK_SUBEXPR (fa
->var
);
3274 WALK_SUBEXPR (fa
->start
);
3275 WALK_SUBEXPR (fa
->end
);
3276 WALK_SUBEXPR (fa
->stride
);
3278 if (co
->op
== EXEC_FORALL
)
3284 WALK_SUBEXPR (co
->ext
.open
->unit
);
3285 WALK_SUBEXPR (co
->ext
.open
->file
);
3286 WALK_SUBEXPR (co
->ext
.open
->status
);
3287 WALK_SUBEXPR (co
->ext
.open
->access
);
3288 WALK_SUBEXPR (co
->ext
.open
->form
);
3289 WALK_SUBEXPR (co
->ext
.open
->recl
);
3290 WALK_SUBEXPR (co
->ext
.open
->blank
);
3291 WALK_SUBEXPR (co
->ext
.open
->position
);
3292 WALK_SUBEXPR (co
->ext
.open
->action
);
3293 WALK_SUBEXPR (co
->ext
.open
->delim
);
3294 WALK_SUBEXPR (co
->ext
.open
->pad
);
3295 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3296 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3297 WALK_SUBEXPR (co
->ext
.open
->convert
);
3298 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3299 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3300 WALK_SUBEXPR (co
->ext
.open
->round
);
3301 WALK_SUBEXPR (co
->ext
.open
->sign
);
3302 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3303 WALK_SUBEXPR (co
->ext
.open
->id
);
3304 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3308 WALK_SUBEXPR (co
->ext
.close
->unit
);
3309 WALK_SUBEXPR (co
->ext
.close
->status
);
3310 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3311 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3314 case EXEC_BACKSPACE
:
3318 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3319 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3320 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3324 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3325 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3326 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3327 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3328 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3329 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3330 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3331 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3332 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3333 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3334 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3335 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3336 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3337 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3338 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3339 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3340 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3341 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3342 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3343 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3344 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3345 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3346 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3347 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3348 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3349 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3350 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3351 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3352 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3353 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3354 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3355 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3356 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3357 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3358 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3359 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3363 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3364 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3365 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3366 WALK_SUBEXPR (co
->ext
.wait
->id
);
3371 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3372 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3373 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3374 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3375 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3376 WALK_SUBEXPR (co
->ext
.dt
->size
);
3377 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3378 WALK_SUBEXPR (co
->ext
.dt
->id
);
3379 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3380 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3381 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3382 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3383 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3384 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3385 WALK_SUBEXPR (co
->ext
.dt
->round
);
3386 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3387 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3390 case EXEC_OMP_PARALLEL
:
3391 case EXEC_OMP_PARALLEL_DO
:
3392 case EXEC_OMP_PARALLEL_DO_SIMD
:
3393 case EXEC_OMP_PARALLEL_SECTIONS
:
3395 in_omp_workshare
= false;
3397 /* This goto serves as a shortcut to avoid code
3398 duplication or a larger if or switch statement. */
3399 goto check_omp_clauses
;
3401 case EXEC_OMP_WORKSHARE
:
3402 case EXEC_OMP_PARALLEL_WORKSHARE
:
3404 in_omp_workshare
= true;
3408 case EXEC_OMP_DISTRIBUTE
:
3409 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3410 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3411 case EXEC_OMP_DISTRIBUTE_SIMD
:
3413 case EXEC_OMP_DO_SIMD
:
3414 case EXEC_OMP_SECTIONS
:
3415 case EXEC_OMP_SINGLE
:
3416 case EXEC_OMP_END_SINGLE
:
3418 case EXEC_OMP_TARGET
:
3419 case EXEC_OMP_TARGET_DATA
:
3420 case EXEC_OMP_TARGET_TEAMS
:
3421 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3422 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3423 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3424 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3425 case EXEC_OMP_TARGET_UPDATE
:
3427 case EXEC_OMP_TEAMS
:
3428 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3429 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3430 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3431 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3433 /* Come to this label only from the
3434 EXEC_OMP_PARALLEL_* cases above. */
3438 if (co
->ext
.omp_clauses
)
3440 gfc_omp_namelist
*n
;
3441 static int list_types
[]
3442 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3443 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3445 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3446 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3447 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3448 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3449 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3450 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3451 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3452 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3453 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3454 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3456 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3458 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3460 WALK_SUBEXPR (n
->expr
);
3467 WALK_SUBEXPR (co
->expr1
);
3468 WALK_SUBEXPR (co
->expr2
);
3469 WALK_SUBEXPR (co
->expr3
);
3470 WALK_SUBEXPR (co
->expr4
);
3471 for (b
= co
->block
; b
; b
= b
->block
)
3473 WALK_SUBEXPR (b
->expr1
);
3474 WALK_SUBEXPR (b
->expr2
);
3475 WALK_SUBCODE (b
->next
);
3478 if (co
->op
== EXEC_FORALL
)
3481 if (co
->op
== EXEC_DO
)
3484 in_omp_workshare
= saved_in_omp_workshare
;