1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static void optimize_reduction (gfc_namespace
*);
43 static int callback_reduction (gfc_expr
**, int *, void *);
44 static void realloc_strings (gfc_namespace
*);
45 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
46 static int inline_matmul_assign (gfc_code
**, int *, void *);
47 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
48 locus
*, gfc_namespace
*,
51 /* How deep we are inside an argument list. */
53 static int count_arglist
;
55 /* Vector of gfc_expr ** we operate on. */
57 static vec
<gfc_expr
**> expr_array
;
59 /* Pointer to the gfc_code we currently work on - to be able to insert
60 a block before the statement. */
62 static gfc_code
**current_code
;
64 /* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
67 static gfc_code
*inserted_block
, **changed_statement
;
69 /* The namespace we are currently dealing with. */
71 static gfc_namespace
*current_ns
;
73 /* If we are within any forall loop. */
75 static int forall_level
;
77 /* Keep track of whether we are within an OMP workshare. */
79 static bool in_omp_workshare
;
81 /* Keep track of iterators for array constructors. */
83 static int iterator_level
;
85 /* Keep track of DO loop levels. */
87 static vec
<gfc_code
*> doloop_list
;
89 static int doloop_level
;
91 /* Vector of gfc_expr * to keep track of DO loops. */
93 struct my_struct
*evec
;
95 /* Keep track of association lists. */
97 static bool in_assoc_list
;
99 /* Counter for temporary variables. */
101 static int var_num
= 1;
103 /* What sort of matrix we are dealing with when inlining MATMUL. */
105 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
};
107 /* Keep track of the number of expressions we have inserted so far
112 /* Entry point - run all passes for a namespace. */
115 gfc_run_passes (gfc_namespace
*ns
)
118 /* Warn about dubious DO loops where the index might
123 doloop_list
.release ();
125 if (flag_frontend_optimize
)
127 optimize_namespace (ns
);
128 optimize_reduction (ns
);
129 if (flag_dump_fortran_optimized
)
130 gfc_dump_parse_tree (ns
, stdout
);
132 expr_array
.release ();
135 if (flag_realloc_lhs
)
136 realloc_strings (ns
);
139 /* Callback for each gfc_code node invoked from check_realloc_strings.
140 For an allocatable LHS string which also appears as a variable on
152 realloc_string_callback (gfc_code
**c
, int *walk_subtrees
,
153 void *data ATTRIBUTE_UNUSED
)
155 gfc_expr
*expr1
, *expr2
;
160 if (co
->op
!= EXEC_ASSIGN
)
164 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
165 || !expr1
->symtree
->n
.sym
->attr
.allocatable
)
168 expr2
= gfc_discard_nops (co
->expr2
);
169 if (expr2
->expr_type
!= EXPR_VARIABLE
)
172 if (!gfc_check_dependency (expr1
, expr2
, true))
176 n
= create_var (expr2
, "trim");
181 /* Callback for each gfc_code node invoked through gfc_code_walker
182 from optimize_namespace. */
185 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
186 void *data ATTRIBUTE_UNUSED
)
193 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
194 || op
== EXEC_CALL_PPC
)
200 inserted_block
= NULL
;
201 changed_statement
= NULL
;
203 if (op
== EXEC_ASSIGN
)
204 optimize_assignment (*c
);
208 /* Callback for each gfc_expr node invoked through gfc_code_walker
209 from optimize_namespace. */
212 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
213 void *data ATTRIBUTE_UNUSED
)
217 if ((*e
)->expr_type
== EXPR_FUNCTION
)
220 function_expr
= true;
223 function_expr
= false;
225 if (optimize_trim (*e
))
226 gfc_simplify_expr (*e
, 0);
228 if (optimize_lexical_comparison (*e
))
229 gfc_simplify_expr (*e
, 0);
231 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
232 gfc_simplify_expr (*e
, 0);
234 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
235 switch ((*e
)->value
.function
.isym
->id
)
237 case GFC_ISYM_MINLOC
:
238 case GFC_ISYM_MAXLOC
:
239 optimize_minmaxloc (e
);
251 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
252 function is a scalar, just copy it; otherwise returns the new element, the
253 old one can be freed. */
256 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
258 gfc_expr
*fcn
, *e
= c
->expr
;
260 fcn
= gfc_copy_expr (e
);
263 gfc_constructor_base newbase
;
265 gfc_constructor
*new_c
;
268 new_expr
= gfc_get_expr ();
269 new_expr
->expr_type
= EXPR_ARRAY
;
270 new_expr
->ts
= e
->ts
;
271 new_expr
->where
= e
->where
;
273 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
274 new_c
->iterator
= c
->iterator
;
275 new_expr
->value
.constructor
= newbase
;
283 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
285 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
286 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
287 fn
->value
.function
.isym
->name
,
288 fn
->where
, 3, fcn
, NULL
, NULL
);
289 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
290 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
291 fn
->value
.function
.isym
->name
,
292 fn
->where
, 2, fcn
, NULL
);
294 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
296 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
302 /* Callback function for optimzation of reductions to scalars. Transform ANY
303 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
304 correspondingly. Handly only the simple cases without MASK and DIM. */
307 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
308 void *data ATTRIBUTE_UNUSED
)
313 gfc_actual_arglist
*a
;
314 gfc_actual_arglist
*dim
;
316 gfc_expr
*res
, *new_expr
;
317 gfc_actual_arglist
*mask
;
321 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
322 || fn
->value
.function
.isym
== NULL
)
325 id
= fn
->value
.function
.isym
->id
;
327 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
328 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
331 a
= fn
->value
.function
.actual
;
333 /* Don't handle MASK or DIM. */
337 if (dim
->expr
!= NULL
)
340 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
343 if ( mask
->expr
!= NULL
)
349 if (arg
->expr_type
!= EXPR_ARRAY
)
358 case GFC_ISYM_PRODUCT
:
359 op
= INTRINSIC_TIMES
;
374 c
= gfc_constructor_first (arg
->value
.constructor
);
376 /* Don't do any simplififcation if we have
377 - no element in the constructor or
378 - only have a single element in the array which contains an
384 res
= copy_walk_reduction_arg (c
, fn
);
386 c
= gfc_constructor_next (c
);
389 new_expr
= gfc_get_expr ();
390 new_expr
->ts
= fn
->ts
;
391 new_expr
->expr_type
= EXPR_OP
;
392 new_expr
->rank
= fn
->rank
;
393 new_expr
->where
= fn
->where
;
394 new_expr
->value
.op
.op
= op
;
395 new_expr
->value
.op
.op1
= res
;
396 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
398 c
= gfc_constructor_next (c
);
401 gfc_simplify_expr (res
, 0);
408 /* Callback function for common function elimination, called from cfe_expr_0.
409 Put all eligible function expressions into expr_array. */
412 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
413 void *data ATTRIBUTE_UNUSED
)
416 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
419 /* We don't do character functions with unknown charlens. */
420 if ((*e
)->ts
.type
== BT_CHARACTER
421 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
422 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
425 /* We don't do function elimination within FORALL statements, it can
426 lead to wrong-code in certain circumstances. */
428 if (forall_level
> 0)
431 /* Function elimination inside an iterator could lead to functions which
432 depend on iterator variables being moved outside. FIXME: We should check
433 if the functions do indeed depend on the iterator variable. */
435 if (iterator_level
> 0)
438 /* If we don't know the shape at compile time, we create an allocatable
439 temporary variable to hold the intermediate result, but only if
440 allocation on assignment is active. */
442 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
445 /* Skip the test for pure functions if -faggressive-function-elimination
447 if ((*e
)->value
.function
.esym
)
449 /* Don't create an array temporary for elemental functions. */
450 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
453 /* Only eliminate potentially impure functions if the
454 user specifically requested it. */
455 if (!flag_aggressive_function_elimination
456 && !(*e
)->value
.function
.esym
->attr
.pure
457 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
461 if ((*e
)->value
.function
.isym
)
463 /* Conversions are handled on the fly by the middle end,
464 transpose during trans-* stages and TRANSFER by the middle end. */
465 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
466 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
467 || gfc_inline_intrinsic_function_p (*e
))
470 /* Don't create an array temporary for elemental functions,
471 as this would be wasteful of memory.
472 FIXME: Create a scalar temporary during scalarization. */
473 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
476 if (!(*e
)->value
.function
.isym
->pure
)
480 expr_array
.safe_push (e
);
484 /* Auxiliary function to check if an expression is a temporary created by
488 is_fe_temp (gfc_expr
*e
)
490 if (e
->expr_type
!= EXPR_VARIABLE
)
493 return e
->symtree
->n
.sym
->attr
.fe_temp
;
496 /* Determine the length of a string, if it can be evaluated as a constant
497 expression. Return a newly allocated gfc_expr or NULL on failure.
498 If the user specified a substring which is potentially longer than
499 the string itself, the string will be padded with spaces, which
503 constant_string_length (gfc_expr
*e
)
513 length
= e
->ts
.u
.cl
->length
;
514 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
515 return gfc_copy_expr(length
);
518 /* Return length of substring, if constant. */
519 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
521 if (ref
->type
== REF_SUBSTRING
522 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
524 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
527 mpz_add_ui (res
->value
.integer
, value
, 1);
533 /* Return length of char symbol, if constant. */
535 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
536 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
537 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
543 /* Insert a block at the current position unless it has already
544 been inserted; in this case use the one already there. */
546 static gfc_namespace
*
551 /* If the block hasn't already been created, do so. */
552 if (inserted_block
== NULL
)
554 inserted_block
= XCNEW (gfc_code
);
555 inserted_block
->op
= EXEC_BLOCK
;
556 inserted_block
->loc
= (*current_code
)->loc
;
557 ns
= gfc_build_block_ns (current_ns
);
558 inserted_block
->ext
.block
.ns
= ns
;
559 inserted_block
->ext
.block
.assoc
= NULL
;
561 ns
->code
= *current_code
;
563 /* If the statement has a label, make sure it is transferred to
564 the newly created block. */
566 if ((*current_code
)->here
)
568 inserted_block
->here
= (*current_code
)->here
;
569 (*current_code
)->here
= NULL
;
572 inserted_block
->next
= (*current_code
)->next
;
573 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
574 (*current_code
)->next
= NULL
;
575 /* Insert the BLOCK at the right position. */
576 *current_code
= inserted_block
;
577 ns
->parent
= current_ns
;
580 ns
= inserted_block
->ext
.block
.ns
;
585 /* Returns a new expression (a variable) to be used in place of the old one,
586 with an optional assignment statement before the current statement to set
587 the value of the variable. Creates a new BLOCK for the statement if that
588 hasn't already been done and puts the statement, plus the newly created
589 variables, in that block. Special cases: If the expression is constant or
590 a temporary which has already been created, just copy it. */
593 create_var (gfc_expr
* e
, const char *vname
)
595 char name
[GFC_MAX_SYMBOL_LEN
+1];
596 gfc_symtree
*symtree
;
603 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
604 return gfc_copy_expr (e
);
606 ns
= insert_block ();
609 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
611 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
613 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
616 symbol
= symtree
->n
.sym
;
621 symbol
->as
= gfc_get_array_spec ();
622 symbol
->as
->rank
= e
->rank
;
624 if (e
->shape
== NULL
)
626 /* We don't know the shape at compile time, so we use an
628 symbol
->as
->type
= AS_DEFERRED
;
629 symbol
->attr
.allocatable
= 1;
633 symbol
->as
->type
= AS_EXPLICIT
;
634 /* Copy the shape. */
635 for (i
=0; i
<e
->rank
; i
++)
639 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
641 mpz_set_si (p
->value
.integer
, 1);
642 symbol
->as
->lower
[i
] = p
;
644 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
646 mpz_set (q
->value
.integer
, e
->shape
[i
]);
647 symbol
->as
->upper
[i
] = q
;
652 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
656 length
= constant_string_length (e
);
659 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
660 symbol
->ts
.u
.cl
->length
= length
;
663 symbol
->attr
.allocatable
= 1;
666 symbol
->attr
.flavor
= FL_VARIABLE
;
667 symbol
->attr
.referenced
= 1;
668 symbol
->attr
.dimension
= e
->rank
> 0;
669 symbol
->attr
.fe_temp
= 1;
670 gfc_commit_symbol (symbol
);
672 result
= gfc_get_expr ();
673 result
->expr_type
= EXPR_VARIABLE
;
675 result
->rank
= e
->rank
;
676 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
677 result
->symtree
= symtree
;
678 result
->where
= e
->where
;
681 result
->ref
= gfc_get_ref ();
682 result
->ref
->type
= REF_ARRAY
;
683 result
->ref
->u
.ar
.type
= AR_FULL
;
684 result
->ref
->u
.ar
.where
= e
->where
;
685 result
->ref
->u
.ar
.dimen
= e
->rank
;
686 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
687 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
688 if (warn_array_temporaries
)
689 gfc_warning (OPT_Warray_temporaries
,
690 "Creating array temporary at %L", &(e
->where
));
693 /* Generate the new assignment. */
694 n
= XCNEW (gfc_code
);
696 n
->loc
= (*current_code
)->loc
;
697 n
->next
= *changed_statement
;
698 n
->expr1
= gfc_copy_expr (result
);
700 *changed_statement
= n
;
706 /* Warn about function elimination. */
709 do_warn_function_elimination (gfc_expr
*e
)
711 if (e
->expr_type
!= EXPR_FUNCTION
)
713 if (e
->value
.function
.esym
)
714 gfc_warning (0, "Removing call to function %qs at %L",
715 e
->value
.function
.esym
->name
, &(e
->where
));
716 else if (e
->value
.function
.isym
)
717 gfc_warning (0, "Removing call to function %qs at %L",
718 e
->value
.function
.isym
->name
, &(e
->where
));
720 /* Callback function for the code walker for doing common function
721 elimination. This builds up the list of functions in the expression
722 and goes through them to detect duplicates, which it then replaces
726 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
727 void *data ATTRIBUTE_UNUSED
)
733 /* Don't do this optimization within OMP workshare. */
735 if (in_omp_workshare
)
741 expr_array
.release ();
743 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
745 /* Walk through all the functions. */
747 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
749 /* Skip if the function has been replaced by a variable already. */
750 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
757 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
760 newvar
= create_var (*ei
, "fcn");
762 if (warn_function_elimination
)
763 do_warn_function_elimination (*ej
);
766 *ej
= gfc_copy_expr (newvar
);
773 /* We did all the necessary walking in this function. */
778 /* Callback function for common function elimination, called from
779 gfc_code_walker. This keeps track of the current code, in order
780 to insert statements as needed. */
783 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
786 inserted_block
= NULL
;
787 changed_statement
= NULL
;
789 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
790 and allocation on assigment are prohibited inside WHERE, and finally
791 masking an expression would lead to wrong-code when replacing
794 b = sum(foo(a) + foo(a))
805 if ((*c
)->op
== EXEC_WHERE
)
815 /* Dummy function for expression call back, for use when we
816 really don't want to do any walking. */
819 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
820 void *data ATTRIBUTE_UNUSED
)
826 /* Dummy function for code callback, for use when we really
827 don't want to do anything. */
829 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
830 int *walk_subtrees ATTRIBUTE_UNUSED
,
831 void *data ATTRIBUTE_UNUSED
)
836 /* Code callback function for converting
843 This is because common function elimination would otherwise place the
844 temporary variables outside the loop. */
847 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
848 void *data ATTRIBUTE_UNUSED
)
851 gfc_code
*c_if1
, *c_if2
, *c_exit
;
853 gfc_expr
*e_not
, *e_cond
;
855 if (co
->op
!= EXEC_DO_WHILE
)
858 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
863 /* Generate the condition of the if statement, which is .not. the original
865 e_not
= gfc_get_expr ();
866 e_not
->ts
= e_cond
->ts
;
867 e_not
->where
= e_cond
->where
;
868 e_not
->expr_type
= EXPR_OP
;
869 e_not
->value
.op
.op
= INTRINSIC_NOT
;
870 e_not
->value
.op
.op1
= e_cond
;
872 /* Generate the EXIT statement. */
873 c_exit
= XCNEW (gfc_code
);
874 c_exit
->op
= EXEC_EXIT
;
875 c_exit
->ext
.which_construct
= co
;
876 c_exit
->loc
= co
->loc
;
878 /* Generate the IF statement. */
879 c_if2
= XCNEW (gfc_code
);
881 c_if2
->expr1
= e_not
;
882 c_if2
->next
= c_exit
;
883 c_if2
->loc
= co
->loc
;
885 /* ... plus the one to chain it to. */
886 c_if1
= XCNEW (gfc_code
);
888 c_if1
->block
= c_if2
;
889 c_if1
->loc
= co
->loc
;
891 /* Make the DO WHILE loop into a DO block by replacing the condition
892 with a true constant. */
893 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
895 /* Hang the generated if statement into the loop body. */
897 loopblock
= co
->block
->next
;
898 co
->block
->next
= c_if1
;
899 c_if1
->next
= loopblock
;
904 /* Code callback function for converting
917 because otherwise common function elimination would place the BLOCKs
918 into the wrong place. */
921 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
922 void *data ATTRIBUTE_UNUSED
)
925 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
927 if (co
->op
!= EXEC_IF
)
930 /* This loop starts out with the first ELSE statement. */
931 else_stmt
= co
->block
->block
;
933 while (else_stmt
!= NULL
)
937 /* If there is no condition, we're done. */
938 if (else_stmt
->expr1
== NULL
)
941 next_else
= else_stmt
->block
;
943 /* Generate the new IF statement. */
944 c_if2
= XCNEW (gfc_code
);
946 c_if2
->expr1
= else_stmt
->expr1
;
947 c_if2
->next
= else_stmt
->next
;
948 c_if2
->loc
= else_stmt
->loc
;
949 c_if2
->block
= next_else
;
951 /* ... plus the one to chain it to. */
952 c_if1
= XCNEW (gfc_code
);
954 c_if1
->block
= c_if2
;
955 c_if1
->loc
= else_stmt
->loc
;
957 /* Insert the new IF after the ELSE. */
958 else_stmt
->expr1
= NULL
;
959 else_stmt
->next
= c_if1
;
960 else_stmt
->block
= NULL
;
962 else_stmt
= next_else
;
964 /* Don't walk subtrees. */
968 /* Optimize a namespace, including all contained namespaces. */
971 optimize_namespace (gfc_namespace
*ns
)
973 gfc_namespace
*saved_ns
= gfc_current_ns
;
978 in_assoc_list
= false;
979 in_omp_workshare
= false;
981 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
982 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
983 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
984 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
985 if (flag_inline_matmul_limit
!= 0)
986 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
989 /* BLOCKs are handled in the expression walker below. */
990 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
992 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
993 optimize_namespace (ns
);
995 gfc_current_ns
= saved_ns
;
998 /* Handle dependencies for allocatable strings which potentially redefine
999 themselves in an assignment. */
1002 realloc_strings (gfc_namespace
*ns
)
1005 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1007 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1009 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1010 realloc_strings (ns
);
1016 optimize_reduction (gfc_namespace
*ns
)
1019 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1020 callback_reduction
, NULL
);
1022 /* BLOCKs are handled in the expression walker below. */
1023 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1025 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1026 optimize_reduction (ns
);
1030 /* Replace code like
1033 a = matmul(b,c) ; a = a + d
1034 where the array function is not elemental and not allocatable
1035 and does not depend on the left-hand side.
1039 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1044 if (e
->expr_type
== EXPR_OP
)
1046 switch (e
->value
.op
.op
)
1048 /* Unary operators and exponentiation: Only look at a single
1051 case INTRINSIC_UPLUS
:
1052 case INTRINSIC_UMINUS
:
1053 case INTRINSIC_PARENTHESES
:
1054 case INTRINSIC_POWER
:
1055 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1059 case INTRINSIC_CONCAT
:
1060 /* Do not do string concatenations. */
1064 /* Binary operators. */
1065 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1068 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1074 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1075 && ! (e
->value
.function
.esym
1076 && (e
->value
.function
.esym
->attr
.elemental
1077 || e
->value
.function
.esym
->attr
.allocatable
1078 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1079 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1080 && ! (e
->value
.function
.isym
1081 && (e
->value
.function
.isym
->elemental
1082 || e
->ts
.type
!= c
->expr1
->ts
.type
1083 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1084 && ! gfc_inline_intrinsic_function_p (e
))
1090 /* Insert a new assignment statement after the current one. */
1091 n
= XCNEW (gfc_code
);
1092 n
->op
= EXEC_ASSIGN
;
1097 n
->expr1
= gfc_copy_expr (c
->expr1
);
1098 n
->expr2
= c
->expr2
;
1099 new_expr
= gfc_copy_expr (c
->expr1
);
1107 /* Nothing to optimize. */
1111 /* Remove unneeded TRIMs at the end of expressions. */
1114 remove_trim (gfc_expr
*rhs
)
1120 /* Check for a // b // trim(c). Looping is probably not
1121 necessary because the parser usually generates
1122 (// (// a b ) trim(c) ) , but better safe than sorry. */
1124 while (rhs
->expr_type
== EXPR_OP
1125 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1126 rhs
= rhs
->value
.op
.op2
;
1128 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1129 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1131 strip_function_call (rhs
);
1132 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1140 /* Optimizations for an assignment. */
1143 optimize_assignment (gfc_code
* c
)
1145 gfc_expr
*lhs
, *rhs
;
1150 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1152 /* Optimize a = trim(b) to a = b. */
1155 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1156 if (is_empty_string (rhs
))
1157 rhs
->value
.character
.length
= 0;
1160 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1161 optimize_binop_array_assignment (c
, &rhs
, false);
1165 /* Remove an unneeded function call, modifying the expression.
1166 This replaces the function call with the value of its
1167 first argument. The rest of the argument list is freed. */
1170 strip_function_call (gfc_expr
*e
)
1173 gfc_actual_arglist
*a
;
1175 a
= e
->value
.function
.actual
;
1177 /* We should have at least one argument. */
1178 gcc_assert (a
->expr
!= NULL
);
1182 /* Free the remaining arglist, if any. */
1184 gfc_free_actual_arglist (a
->next
);
1186 /* Graft the argument expression onto the original function. */
1192 /* Optimization of lexical comparison functions. */
1195 optimize_lexical_comparison (gfc_expr
*e
)
1197 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1200 switch (e
->value
.function
.isym
->id
)
1203 return optimize_comparison (e
, INTRINSIC_LE
);
1206 return optimize_comparison (e
, INTRINSIC_GE
);
1209 return optimize_comparison (e
, INTRINSIC_GT
);
1212 return optimize_comparison (e
, INTRINSIC_LT
);
1220 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1221 do CHARACTER because of possible pessimization involving character
1225 combine_array_constructor (gfc_expr
*e
)
1228 gfc_expr
*op1
, *op2
;
1231 gfc_constructor
*c
, *new_c
;
1232 gfc_constructor_base oldbase
, newbase
;
1235 /* Array constructors have rank one. */
1239 /* Don't try to combine association lists, this makes no sense
1240 and leads to an ICE. */
1244 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1245 if (forall_level
> 0)
1248 op1
= e
->value
.op
.op1
;
1249 op2
= e
->value
.op
.op2
;
1251 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1252 scalar_first
= false;
1253 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1255 scalar_first
= true;
1256 op1
= e
->value
.op
.op2
;
1257 op2
= e
->value
.op
.op1
;
1262 if (op2
->ts
.type
== BT_CHARACTER
)
1265 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1267 oldbase
= op1
->value
.constructor
;
1269 e
->expr_type
= EXPR_ARRAY
;
1271 for (c
= gfc_constructor_first (oldbase
); c
;
1272 c
= gfc_constructor_next (c
))
1274 new_expr
= gfc_get_expr ();
1275 new_expr
->ts
= e
->ts
;
1276 new_expr
->expr_type
= EXPR_OP
;
1277 new_expr
->rank
= c
->expr
->rank
;
1278 new_expr
->where
= c
->where
;
1279 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1283 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1284 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1288 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1289 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1292 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1293 new_c
->iterator
= c
->iterator
;
1297 gfc_free_expr (op1
);
1298 gfc_free_expr (op2
);
1299 gfc_free_expr (scalar
);
1301 e
->value
.constructor
= newbase
;
1305 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1306 2**k into ishift(1,k) */
1309 optimize_power (gfc_expr
*e
)
1311 gfc_expr
*op1
, *op2
;
1312 gfc_expr
*iand
, *ishft
;
1314 if (e
->ts
.type
!= BT_INTEGER
)
1317 op1
= e
->value
.op
.op1
;
1319 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1322 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1324 gfc_free_expr (op1
);
1326 op2
= e
->value
.op
.op2
;
1331 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1332 "_internal_iand", e
->where
, 2, op2
,
1333 gfc_get_int_expr (e
->ts
.kind
,
1336 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1337 "_internal_ishft", e
->where
, 2, iand
,
1338 gfc_get_int_expr (e
->ts
.kind
,
1341 e
->value
.op
.op
= INTRINSIC_MINUS
;
1342 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1343 e
->value
.op
.op2
= ishft
;
1346 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1348 gfc_free_expr (op1
);
1350 op2
= e
->value
.op
.op2
;
1354 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1355 "_internal_ishft", e
->where
, 2,
1356 gfc_get_int_expr (e
->ts
.kind
,
1363 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1365 op2
= e
->value
.op
.op2
;
1369 gfc_free_expr (op1
);
1370 gfc_free_expr (op2
);
1372 e
->expr_type
= EXPR_CONSTANT
;
1373 e
->value
.op
.op1
= NULL
;
1374 e
->value
.op
.op2
= NULL
;
1375 mpz_init_set_si (e
->value
.integer
, 1);
1376 /* Typespec and location are still OK. */
1383 /* Recursive optimization of operators. */
1386 optimize_op (gfc_expr
*e
)
1390 gfc_intrinsic_op op
= e
->value
.op
.op
;
1394 /* Only use new-style comparisons. */
1397 case INTRINSIC_EQ_OS
:
1401 case INTRINSIC_GE_OS
:
1405 case INTRINSIC_LE_OS
:
1409 case INTRINSIC_NE_OS
:
1413 case INTRINSIC_GT_OS
:
1417 case INTRINSIC_LT_OS
:
1433 changed
= optimize_comparison (e
, op
);
1436 /* Look at array constructors. */
1437 case INTRINSIC_PLUS
:
1438 case INTRINSIC_MINUS
:
1439 case INTRINSIC_TIMES
:
1440 case INTRINSIC_DIVIDE
:
1441 return combine_array_constructor (e
) || changed
;
1443 case INTRINSIC_POWER
:
1444 return optimize_power (e
);
1455 /* Return true if a constant string contains only blanks. */
1458 is_empty_string (gfc_expr
*e
)
1462 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1465 for (i
=0; i
< e
->value
.character
.length
; i
++)
1467 if (e
->value
.character
.string
[i
] != ' ')
1475 /* Insert a call to the intrinsic len_trim. Use a different name for
1476 the symbol tree so we don't run into trouble when the user has
1477 renamed len_trim for some reason. */
1480 get_len_trim_call (gfc_expr
*str
, int kind
)
1483 gfc_actual_arglist
*actual_arglist
, *next
;
1485 fcn
= gfc_get_expr ();
1486 fcn
->expr_type
= EXPR_FUNCTION
;
1487 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1488 actual_arglist
= gfc_get_actual_arglist ();
1489 actual_arglist
->expr
= str
;
1490 next
= gfc_get_actual_arglist ();
1491 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1492 actual_arglist
->next
= next
;
1494 fcn
->value
.function
.actual
= actual_arglist
;
1495 fcn
->where
= str
->where
;
1496 fcn
->ts
.type
= BT_INTEGER
;
1497 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1499 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1500 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1501 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1502 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1503 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1504 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1505 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1506 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1511 /* Optimize expressions for equality. */
1514 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1516 gfc_expr
*op1
, *op2
;
1520 gfc_actual_arglist
*firstarg
, *secondarg
;
1522 if (e
->expr_type
== EXPR_OP
)
1526 op1
= e
->value
.op
.op1
;
1527 op2
= e
->value
.op
.op2
;
1529 else if (e
->expr_type
== EXPR_FUNCTION
)
1531 /* One of the lexical comparison functions. */
1532 firstarg
= e
->value
.function
.actual
;
1533 secondarg
= firstarg
->next
;
1534 op1
= firstarg
->expr
;
1535 op2
= secondarg
->expr
;
1540 /* Strip off unneeded TRIM calls from string comparisons. */
1542 change
= remove_trim (op1
);
1544 if (remove_trim (op2
))
1547 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1548 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1549 handles them well). However, there are also cases that need a non-scalar
1550 argument. For example the any intrinsic. See PR 45380. */
1554 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1556 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1557 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1559 bool empty_op1
, empty_op2
;
1560 empty_op1
= is_empty_string (op1
);
1561 empty_op2
= is_empty_string (op2
);
1563 if (empty_op1
|| empty_op2
)
1569 /* This can only happen when an error for comparing
1570 characters of different kinds has already been issued. */
1571 if (empty_op1
&& empty_op2
)
1574 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1575 str
= empty_op1
? op2
: op1
;
1577 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1581 gfc_free_expr (op1
);
1583 gfc_free_expr (op2
);
1587 e
->value
.op
.op1
= fcn
;
1588 e
->value
.op
.op2
= zero
;
1593 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1595 if (flag_finite_math_only
1596 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1597 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1599 eq
= gfc_dep_compare_expr (op1
, op2
);
1602 /* Replace A // B < A // C with B < C, and A // B < C // B
1604 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1605 && op1
->expr_type
== EXPR_OP
1606 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1607 && op2
->expr_type
== EXPR_OP
1608 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1610 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1611 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1612 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1613 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1615 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1617 /* Watch out for 'A ' // x vs. 'A' // x. */
1619 if (op1_left
->expr_type
== EXPR_CONSTANT
1620 && op2_left
->expr_type
== EXPR_CONSTANT
1621 && op1_left
->value
.character
.length
1622 != op2_left
->value
.character
.length
)
1630 firstarg
->expr
= op1_right
;
1631 secondarg
->expr
= op2_right
;
1635 e
->value
.op
.op1
= op1_right
;
1636 e
->value
.op
.op2
= op2_right
;
1638 optimize_comparison (e
, op
);
1642 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1648 firstarg
->expr
= op1_left
;
1649 secondarg
->expr
= op2_left
;
1653 e
->value
.op
.op1
= op1_left
;
1654 e
->value
.op
.op2
= op2_left
;
1657 optimize_comparison (e
, op
);
1664 /* eq can only be -1, 0 or 1 at this point. */
1692 gfc_internal_error ("illegal OP in optimize_comparison");
1696 /* Replace the expression by a constant expression. The typespec
1697 and where remains the way it is. */
1700 e
->expr_type
= EXPR_CONSTANT
;
1701 e
->value
.logical
= result
;
1709 /* Optimize a trim function by replacing it with an equivalent substring
1710 involving a call to len_trim. This only works for expressions where
1711 variables are trimmed. Return true if anything was modified. */
1714 optimize_trim (gfc_expr
*e
)
1719 gfc_ref
**rr
= NULL
;
1721 /* Don't do this optimization within an argument list, because
1722 otherwise aliasing issues may occur. */
1724 if (count_arglist
!= 1)
1727 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1728 || e
->value
.function
.isym
== NULL
1729 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1732 a
= e
->value
.function
.actual
->expr
;
1734 if (a
->expr_type
!= EXPR_VARIABLE
)
1737 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1739 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1742 /* Follow all references to find the correct place to put the newly
1743 created reference. FIXME: Also handle substring references and
1744 array references. Array references cause strange regressions at
1749 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1751 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1756 strip_function_call (e
);
1761 /* Create the reference. */
1763 ref
= gfc_get_ref ();
1764 ref
->type
= REF_SUBSTRING
;
1766 /* Set the start of the reference. */
1768 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1770 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1772 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1774 /* Set the end of the reference to the call to len_trim. */
1776 ref
->u
.ss
.end
= fcn
;
1777 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1782 /* Optimize minloc(b), where b is rank 1 array, into
1783 (/ minloc(b, dim=1) /), and similarly for maxloc,
1784 as the latter forms are expanded inline. */
1787 optimize_minmaxloc (gfc_expr
**e
)
1790 gfc_actual_arglist
*a
;
1794 || fn
->value
.function
.actual
== NULL
1795 || fn
->value
.function
.actual
->expr
== NULL
1796 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1799 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1800 (*e
)->shape
= fn
->shape
;
1803 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1805 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1806 strcpy (name
, fn
->value
.function
.name
);
1807 p
= strstr (name
, "loc0");
1809 fn
->value
.function
.name
= gfc_get_string (name
);
1810 if (fn
->value
.function
.actual
->next
)
1812 a
= fn
->value
.function
.actual
->next
;
1813 gcc_assert (a
->expr
== NULL
);
1817 a
= gfc_get_actual_arglist ();
1818 fn
->value
.function
.actual
->next
= a
;
1820 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1822 mpz_set_ui (a
->expr
->value
.integer
, 1);
1825 /* Callback function for code checking that we do not pass a DO variable to an
1826 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1829 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1830 void *data ATTRIBUTE_UNUSED
)
1834 gfc_formal_arglist
*f
;
1835 gfc_actual_arglist
*a
;
1840 /* If the doloop_list grew, we have to truncate it here. */
1842 if ((unsigned) doloop_level
< doloop_list
.length())
1843 doloop_list
.truncate (doloop_level
);
1849 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1850 doloop_list
.safe_push (co
);
1852 doloop_list
.safe_push ((gfc_code
*) NULL
);
1857 if (co
->resolved_sym
== NULL
)
1860 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1862 /* Withot a formal arglist, there is only unknown INTENT,
1863 which we don't check for. */
1871 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1878 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1880 if (a
->expr
&& a
->expr
->symtree
1881 && a
->expr
->symtree
->n
.sym
== do_sym
)
1883 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1884 gfc_error_now ("Variable %qs at %L set to undefined "
1885 "value inside loop beginning at %L as "
1886 "INTENT(OUT) argument to subroutine %qs",
1887 do_sym
->name
, &a
->expr
->where
,
1888 &doloop_list
[i
]->loc
,
1889 co
->symtree
->n
.sym
->name
);
1890 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1891 gfc_error_now ("Variable %qs at %L not definable inside "
1892 "loop beginning at %L as INTENT(INOUT) "
1893 "argument to subroutine %qs",
1894 do_sym
->name
, &a
->expr
->where
,
1895 &doloop_list
[i
]->loc
,
1896 co
->symtree
->n
.sym
->name
);
1910 /* Callback function for functions checking that we do not pass a DO variable
1911 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1914 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1915 void *data ATTRIBUTE_UNUSED
)
1917 gfc_formal_arglist
*f
;
1918 gfc_actual_arglist
*a
;
1924 if (expr
->expr_type
!= EXPR_FUNCTION
)
1927 /* Intrinsic functions don't modify their arguments. */
1929 if (expr
->value
.function
.isym
)
1932 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1934 /* Without a formal arglist, there is only unknown INTENT,
1935 which we don't check for. */
1939 a
= expr
->value
.function
.actual
;
1943 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1950 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1952 if (a
->expr
&& a
->expr
->symtree
1953 && a
->expr
->symtree
->n
.sym
== do_sym
)
1955 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1956 gfc_error_now ("Variable %qs at %L set to undefined value "
1957 "inside loop beginning at %L as INTENT(OUT) "
1958 "argument to function %qs", do_sym
->name
,
1959 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1960 expr
->symtree
->n
.sym
->name
);
1961 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1962 gfc_error_now ("Variable %qs at %L not definable inside loop"
1963 " beginning at %L as INTENT(INOUT) argument to"
1964 " function %qs", do_sym
->name
,
1965 &a
->expr
->where
, &doloop_list
[i
]->loc
,
1966 expr
->symtree
->n
.sym
->name
);
1977 doloop_warn (gfc_namespace
*ns
)
1979 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
1982 /* This selction deals with inlining calls to MATMUL. */
1984 /* Auxiliary function to build and simplify an array inquiry function.
1985 dim is zero-based. */
1988 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
1991 gfc_expr
*dim_arg
, *kind
;
1997 case GFC_ISYM_LBOUND
:
1998 name
= "_gfortran_lbound";
2001 case GFC_ISYM_UBOUND
:
2002 name
= "_gfortran_ubound";
2006 name
= "_gfortran_size";
2013 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2014 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2015 gfc_index_integer_kind
);
2017 ec
= gfc_copy_expr (e
);
2018 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2020 gfc_simplify_expr (fcn
, 0);
2024 /* Builds a logical expression. */
2027 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2032 ts
.type
= BT_LOGICAL
;
2033 ts
.kind
= gfc_default_logical_kind
;
2034 res
= gfc_get_expr ();
2035 res
->where
= e1
->where
;
2036 res
->expr_type
= EXPR_OP
;
2037 res
->value
.op
.op
= op
;
2038 res
->value
.op
.op1
= e1
;
2039 res
->value
.op
.op2
= e2
;
2046 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2047 compatible typespecs. */
2050 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2054 res
= gfc_get_expr ();
2056 res
->where
= e1
->where
;
2057 res
->expr_type
= EXPR_OP
;
2058 res
->value
.op
.op
= op
;
2059 res
->value
.op
.op1
= e1
;
2060 res
->value
.op
.op2
= e2
;
2061 gfc_simplify_expr (res
, 0);
2065 /* Generate the IF statement for a runtime check if we want to do inlining or
2066 not - putting in the code for both branches and putting it into the syntax
2067 tree is the caller's responsibility. For fixed array sizes, this should be
2068 removed by DCE. Only called for rank-two matrices A and B. */
2071 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2073 gfc_expr
*inline_limit
;
2074 gfc_code
*if_1
, *if_2
, *else_2
;
2075 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2079 gcc_assert (m_case
== A2B2
);
2081 /* Calculation is done in real to avoid integer overflow. */
2083 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2085 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2087 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2090 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2091 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2092 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2096 ts
.kind
= gfc_default_real_kind
;
2097 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2098 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2099 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2101 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2102 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2104 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2105 gfc_simplify_expr (cond
, 0);
2107 else_2
= XCNEW (gfc_code
);
2108 else_2
->op
= EXEC_IF
;
2109 else_2
->loc
= a
->where
;
2111 if_2
= XCNEW (gfc_code
);
2114 if_2
->loc
= a
->where
;
2115 if_2
->block
= else_2
;
2117 if_1
= XCNEW (gfc_code
);
2120 if_1
->loc
= a
->where
;
2126 /* Insert code to issue a runtime error if the expressions are not equal. */
2129 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2132 gfc_code
*if_1
, *if_2
;
2134 gfc_actual_arglist
*a1
, *a2
, *a3
;
2136 gcc_assert (e1
->where
.lb
);
2137 /* Build the call to runtime_error. */
2138 c
= XCNEW (gfc_code
);
2142 /* Get a null-terminated message string. */
2144 a1
= gfc_get_actual_arglist ();
2145 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2146 msg
, strlen(msg
)+1);
2149 /* Pass the value of the first expression. */
2150 a2
= gfc_get_actual_arglist ();
2151 a2
->expr
= gfc_copy_expr (e1
);
2154 /* Pass the value of the second expression. */
2155 a3
= gfc_get_actual_arglist ();
2156 a3
->expr
= gfc_copy_expr (e2
);
2159 gfc_check_fe_runtime_error (c
->ext
.actual
);
2160 gfc_resolve_fe_runtime_error (c
);
2162 if_2
= XCNEW (gfc_code
);
2164 if_2
->loc
= e1
->where
;
2167 if_1
= XCNEW (gfc_code
);
2170 if_1
->loc
= e1
->where
;
2172 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2173 gfc_simplify_expr (cond
, 0);
2179 /* Handle matrix reallocation. Caller is responsible to insert into
2182 For the two-dimensional case, build
2184 if (allocated(c)) then
2185 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2187 allocate (c(size(a,1), size(b,2)))
2190 allocate (c(size(a,1),size(b,2)))
2193 and for the other cases correspondingly.
2197 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2198 enum matrix_case m_case
)
2201 gfc_expr
*allocated
, *alloc_expr
;
2202 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2203 gfc_code
*else_alloc
;
2204 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2206 gfc_expr
*cond
, *ne1
, *ne2
;
2208 if (warn_realloc_lhs
)
2209 gfc_warning (OPT_Wrealloc_lhs
,
2210 "Code for reallocating the allocatable array at %L will "
2211 "be added", &c
->where
);
2213 alloc_expr
= gfc_copy_expr (c
);
2215 ar
= gfc_find_array_ref (alloc_expr
);
2216 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2218 /* c comes in as a full ref. Change it into a copy and make it into an
2219 element ref so it has the right form for for ALLOCATE. In the same
2220 switch statement, also generate the size comparison for the secod IF
2223 ar
->type
= AR_ELEMENT
;
2228 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2229 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2230 ne1
= build_logical_expr (INTRINSIC_NE
,
2231 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2232 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2233 ne2
= build_logical_expr (INTRINSIC_NE
,
2234 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2235 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2236 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2240 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2241 cond
= build_logical_expr (INTRINSIC_NE
,
2242 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2243 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2247 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2248 cond
= build_logical_expr (INTRINSIC_NE
,
2249 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2250 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2258 gfc_simplify_expr (cond
, 0);
2260 /* We need two identical allocate statements in two
2261 branches of the IF statement. */
2263 allocate1
= XCNEW (gfc_code
);
2264 allocate1
->op
= EXEC_ALLOCATE
;
2265 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2266 allocate1
->loc
= c
->where
;
2267 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2269 allocate_else
= XCNEW (gfc_code
);
2270 allocate_else
->op
= EXEC_ALLOCATE
;
2271 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2272 allocate_else
->loc
= c
->where
;
2273 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2275 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2276 "_gfortran_allocated", c
->where
,
2277 1, gfc_copy_expr (c
));
2279 deallocate
= XCNEW (gfc_code
);
2280 deallocate
->op
= EXEC_DEALLOCATE
;
2281 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2282 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2283 deallocate
->next
= allocate1
;
2284 deallocate
->loc
= c
->where
;
2286 if_size_2
= XCNEW (gfc_code
);
2287 if_size_2
->op
= EXEC_IF
;
2288 if_size_2
->expr1
= cond
;
2289 if_size_2
->loc
= c
->where
;
2290 if_size_2
->next
= deallocate
;
2292 if_size_1
= XCNEW (gfc_code
);
2293 if_size_1
->op
= EXEC_IF
;
2294 if_size_1
->block
= if_size_2
;
2295 if_size_1
->loc
= c
->where
;
2297 else_alloc
= XCNEW (gfc_code
);
2298 else_alloc
->op
= EXEC_IF
;
2299 else_alloc
->loc
= c
->where
;
2300 else_alloc
->next
= allocate_else
;
2302 if_alloc_2
= XCNEW (gfc_code
);
2303 if_alloc_2
->op
= EXEC_IF
;
2304 if_alloc_2
->expr1
= allocated
;
2305 if_alloc_2
->loc
= c
->where
;
2306 if_alloc_2
->next
= if_size_1
;
2307 if_alloc_2
->block
= else_alloc
;
2309 if_alloc_1
= XCNEW (gfc_code
);
2310 if_alloc_1
->op
= EXEC_IF
;
2311 if_alloc_1
->block
= if_alloc_2
;
2312 if_alloc_1
->loc
= c
->where
;
2317 /* Callback function for has_function_or_op. */
2320 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2321 void *data ATTRIBUTE_UNUSED
)
2326 return (*e
)->expr_type
== EXPR_FUNCTION
2327 || (*e
)->expr_type
== EXPR_OP
;
2330 /* Returns true if the expression contains a function. */
2333 has_function_or_op (gfc_expr
**e
)
2338 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2341 /* Freeze (assign to a temporary variable) a single expression. */
2344 freeze_expr (gfc_expr
**ep
)
2347 if (has_function_or_op (ep
))
2349 ne
= create_var (*ep
, "freeze");
2354 /* Go through an expression's references and assign them to temporary
2355 variables if they contain functions. This is usually done prior to
2356 front-end scalarization to avoid multiple invocations of functions. */
2359 freeze_references (gfc_expr
*e
)
2365 for (r
=e
->ref
; r
; r
=r
->next
)
2367 if (r
->type
== REF_SUBSTRING
)
2369 if (r
->u
.ss
.start
!= NULL
)
2370 freeze_expr (&r
->u
.ss
.start
);
2372 if (r
->u
.ss
.end
!= NULL
)
2373 freeze_expr (&r
->u
.ss
.end
);
2375 else if (r
->type
== REF_ARRAY
)
2384 for (i
=0; i
<ar
->dimen
; i
++)
2386 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2388 freeze_expr (&ar
->start
[i
]);
2389 freeze_expr (&ar
->end
[i
]);
2390 freeze_expr (&ar
->stride
[i
]);
2392 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2394 freeze_expr (&ar
->start
[i
]);
2400 for (i
=0; i
<ar
->dimen
; i
++)
2401 freeze_expr (&ar
->start
[i
]);
2411 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2414 convert_to_index_kind (gfc_expr
*e
)
2418 gcc_assert (e
!= NULL
);
2420 res
= gfc_copy_expr (e
);
2422 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2424 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2428 ts
.type
= BT_INTEGER
;
2429 ts
.kind
= gfc_index_integer_kind
;
2431 gfc_convert_type_warn (e
, &ts
, 2, 0);
2437 /* Function to create a DO loop including creation of the
2438 iteration variable. gfc_expr are copied.*/
2441 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2442 gfc_namespace
*ns
, char *vname
)
2445 char name
[GFC_MAX_SYMBOL_LEN
+1];
2446 gfc_symtree
*symtree
;
2451 /* Create an expression for the iteration variable. */
2453 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2455 sprintf (name
, "__var_%d_do", var_num
++);
2458 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2461 /* Create the loop variable. */
2463 symbol
= symtree
->n
.sym
;
2464 symbol
->ts
.type
= BT_INTEGER
;
2465 symbol
->ts
.kind
= gfc_index_integer_kind
;
2466 symbol
->attr
.flavor
= FL_VARIABLE
;
2467 symbol
->attr
.referenced
= 1;
2468 symbol
->attr
.dimension
= 0;
2469 symbol
->attr
.fe_temp
= 1;
2470 gfc_commit_symbol (symbol
);
2472 i
= gfc_get_expr ();
2473 i
->expr_type
= EXPR_VARIABLE
;
2477 i
->symtree
= symtree
;
2479 /* ... and the nested DO statements. */
2480 n
= XCNEW (gfc_code
);
2483 n
->ext
.iterator
= gfc_get_iterator ();
2484 n
->ext
.iterator
->var
= i
;
2485 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2486 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2488 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2490 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2493 n2
= XCNEW (gfc_code
);
2501 /* Get the upper bound of the DO loops for matmul along a dimension. This
2505 get_size_m1 (gfc_expr
*e
, int dimen
)
2510 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2512 res
= gfc_get_constant_expr (BT_INTEGER
,
2513 gfc_index_integer_kind
, &e
->where
);
2514 mpz_sub_ui (res
->value
.integer
, size
, 1);
2519 res
= get_operand (INTRINSIC_MINUS
,
2520 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2521 gfc_get_int_expr (gfc_index_integer_kind
,
2523 gfc_simplify_expr (res
, 0);
2529 /* Function to return a scalarized expression. It is assumed that indices are
2530 zero based to make generation of DO loops easier. A zero as index will
2531 access the first element along a dimension. Single element references will
2532 be skipped. A NULL as an expression will be replaced by a full reference.
2533 This assumes that the index loops have gfc_index_integer_kind, and that all
2534 references have been frozen. */
2537 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2546 e
= gfc_copy_expr(e_in
);
2550 ar
= gfc_find_array_ref (e
);
2552 /* We scalarize count_index variables, reducing the rank by count_index. */
2554 e
->rank
= rank
- count_index
;
2556 was_fullref
= ar
->type
== AR_FULL
;
2559 ar
->type
= AR_ELEMENT
;
2561 ar
->type
= AR_SECTION
;
2563 /* Loop over the indices. For each index, create the expression
2564 index * stride + lbound(e, dim). */
2567 for (i
=0; i
< ar
->dimen
; i
++)
2569 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2571 if (index
[i_index
] != NULL
)
2573 gfc_expr
*lbound
, *nindex
;
2576 loopvar
= gfc_copy_expr (index
[i_index
]);
2582 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2583 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2587 ts
.type
= BT_INTEGER
;
2588 ts
.kind
= gfc_index_integer_kind
;
2589 gfc_convert_type (tmp
, &ts
, 2);
2591 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2596 /* Calculate the lower bound of the expression. */
2599 lbound
= gfc_copy_expr (ar
->start
[i
]);
2600 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2604 ts
.type
= BT_INTEGER
;
2605 ts
.kind
= gfc_index_integer_kind
;
2606 gfc_convert_type (lbound
, &ts
, 2);
2615 lbound_e
= gfc_copy_expr (e_in
);
2617 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2618 if (ref
->type
== REF_ARRAY
2619 && (ref
->u
.ar
.type
== AR_FULL
2620 || ref
->u
.ar
.type
== AR_SECTION
))
2625 gfc_free_ref_list (ref
->next
);
2631 /* Look at full individual sections, like a(:). The first index
2632 is the lbound of a full ref. */
2638 for (j
= 0; j
< ar
->dimen
; j
++)
2640 gfc_free_expr (ar
->start
[j
]);
2641 ar
->start
[j
] = NULL
;
2642 gfc_free_expr (ar
->end
[j
]);
2644 gfc_free_expr (ar
->stride
[j
]);
2645 ar
->stride
[j
] = NULL
;
2648 /* We have to get rid of the shape, if there is one. Do
2649 so by freeing it and calling gfc_resolve to rebuild
2650 it, if necessary. */
2652 if (lbound_e
->shape
)
2653 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2655 lbound_e
->rank
= ar
->dimen
;
2656 gfc_resolve_expr (lbound_e
);
2658 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2660 gfc_free_expr (lbound_e
);
2663 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2665 gfc_free_expr (ar
->start
[i
]);
2666 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2668 gfc_free_expr (ar
->end
[i
]);
2670 gfc_free_expr (ar
->stride
[i
]);
2671 ar
->stride
[i
] = NULL
;
2672 gfc_simplify_expr (ar
->start
[i
], 0);
2674 else if (was_fullref
)
2676 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2685 /* Helper function to check for a dimen vector as subscript. */
2688 has_dimen_vector_ref (gfc_expr
*e
)
2693 ar
= gfc_find_array_ref (e
);
2695 if (ar
->type
== AR_FULL
)
2698 for (i
=0; i
<ar
->dimen
; i
++)
2699 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2705 /* If handed an expression of the form
2709 check if A can be handled by matmul and return if there is an uneven number
2710 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2711 otherwise. The caller has to check for the correct rank. */
2714 check_conjg_variable (gfc_expr
*e
, bool *conjg
)
2720 if (e
->expr_type
== EXPR_VARIABLE
)
2722 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2725 else if (e
->expr_type
== EXPR_FUNCTION
)
2727 if (e
->value
.function
.isym
== NULL
)
2730 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2737 e
= e
->value
.function
.actual
->expr
;
2744 /* Inline assignments of the form c = matmul(a,b).
2745 Handle only the cases currently where b and c are rank-two arrays.
2747 This basically translates the code to
2753 do k=0, size(a, 2)-1
2754 do i=0, size(a, 1)-1
2755 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2756 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2757 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2758 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2767 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2768 void *data ATTRIBUTE_UNUSED
)
2771 gfc_expr
*expr1
, *expr2
;
2772 gfc_expr
*matrix_a
, *matrix_b
;
2773 gfc_actual_arglist
*a
, *b
;
2774 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2776 gfc_expr
*u1
, *u2
, *u3
;
2778 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2780 gfc_expr
*var_1
, *var_2
, *var_3
;
2783 gfc_intrinsic_op op_times
, op_plus
;
2784 enum matrix_case m_case
;
2786 gfc_code
*if_limit
= NULL
;
2787 gfc_code
**next_code_point
;
2788 bool conjg_a
, conjg_b
;
2790 if (co
->op
!= EXEC_ASSIGN
)
2795 if (expr2
->expr_type
!= EXPR_FUNCTION
2796 || expr2
->value
.function
.isym
== NULL
2797 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2801 inserted_block
= NULL
;
2802 changed_statement
= NULL
;
2804 a
= expr2
->value
.function
.actual
;
2805 matrix_a
= check_conjg_variable (a
->expr
, &conjg_a
);
2806 if (matrix_a
== NULL
)
2810 matrix_b
= check_conjg_variable (b
->expr
, &conjg_b
);
2811 if (matrix_b
== NULL
)
2814 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2815 || has_dimen_vector_ref (matrix_b
))
2818 /* We do not handle data dependencies yet. */
2819 if (gfc_check_dependency (expr1
, matrix_a
, true)
2820 || gfc_check_dependency (expr1
, matrix_b
, true))
2823 if (matrix_a
->rank
== 2)
2824 m_case
= matrix_b
->rank
== 1 ? A2B1
: A2B2
;
2829 ns
= insert_block ();
2831 /* Assign the type of the zero expression for initializing the resulting
2832 array, and the expression (+ and * for real, integer and complex;
2833 .and. and .or for logical. */
2835 switch(expr1
->ts
.type
)
2838 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2839 op_times
= INTRINSIC_TIMES
;
2840 op_plus
= INTRINSIC_PLUS
;
2844 op_times
= INTRINSIC_AND
;
2845 op_plus
= INTRINSIC_OR
;
2846 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2850 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2852 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2853 op_times
= INTRINSIC_TIMES
;
2854 op_plus
= INTRINSIC_PLUS
;
2858 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2860 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2861 op_times
= INTRINSIC_TIMES
;
2862 op_plus
= INTRINSIC_PLUS
;
2870 current_code
= &ns
->code
;
2872 /* Freeze the references, keeping track of how many temporary variables were
2875 freeze_references (matrix_a
);
2876 freeze_references (matrix_b
);
2877 freeze_references (expr1
);
2880 next_code_point
= current_code
;
2883 next_code_point
= &ns
->code
;
2884 for (i
=0; i
<n_vars
; i
++)
2885 next_code_point
= &(*next_code_point
)->next
;
2888 /* Take care of the inline flag. If the limit check evaluates to a
2889 constant, dead code elimination will eliminate the unneeded branch. */
2891 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2893 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2895 /* Insert the original statement into the else branch. */
2896 if_limit
->block
->block
->next
= co
;
2899 /* ... and the new ones go into the original one. */
2900 *next_code_point
= if_limit
;
2901 next_code_point
= &if_limit
->block
->next
;
2904 assign_zero
= XCNEW (gfc_code
);
2905 assign_zero
->op
= EXEC_ASSIGN
;
2906 assign_zero
->loc
= co
->loc
;
2907 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2908 assign_zero
->expr2
= zero_e
;
2910 /* Handle the reallocation, if needed. */
2911 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
2913 gfc_code
*lhs_alloc
;
2915 /* Only need to check a single dimension for the A2B2 case for
2916 bounds checking, the rest will be allocated. */
2918 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
2923 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2924 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2925 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2926 "in MATMUL intrinsic: Is %ld, should be %ld");
2927 *next_code_point
= test
;
2928 next_code_point
= &test
->next
;
2932 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
2934 *next_code_point
= lhs_alloc
;
2935 next_code_point
= &lhs_alloc
->next
;
2938 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
2941 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
2943 if (m_case
== A2B2
|| m_case
== A2B1
)
2945 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
2946 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2947 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
2948 "in MATMUL intrinsic: Is %ld, should be %ld");
2949 *next_code_point
= test
;
2950 next_code_point
= &test
->next
;
2952 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2953 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2956 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2957 "MATMUL intrinsic for dimension 1: "
2958 "is %ld, should be %ld");
2959 else if (m_case
== A2B1
)
2960 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
2961 "MATMUL intrinsic: "
2962 "is %ld, should be %ld");
2965 *next_code_point
= test
;
2966 next_code_point
= &test
->next
;
2968 else if (m_case
== A1B2
)
2970 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
2971 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
2972 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
2973 "in MATMUL intrinsic: Is %ld, should be %ld");
2974 *next_code_point
= test
;
2975 next_code_point
= &test
->next
;
2977 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
2978 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2980 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
2981 "MATMUL intrinsic: "
2982 "is %ld, should be %ld");
2984 *next_code_point
= test
;
2985 next_code_point
= &test
->next
;
2990 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
2991 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
2992 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
2993 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
2995 *next_code_point
= test
;
2996 next_code_point
= &test
->next
;
3000 *next_code_point
= assign_zero
;
3002 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3004 assign_matmul
= XCNEW (gfc_code
);
3005 assign_matmul
->op
= EXEC_ASSIGN
;
3006 assign_matmul
->loc
= co
->loc
;
3008 /* Get the bounds for the loops, create them and create the scalarized
3014 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3016 u1
= get_size_m1 (matrix_b
, 2);
3017 u2
= get_size_m1 (matrix_a
, 2);
3018 u3
= get_size_m1 (matrix_a
, 1);
3020 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3021 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3022 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3024 do_1
->block
->next
= do_2
;
3025 do_2
->block
->next
= do_3
;
3026 do_3
->block
->next
= assign_matmul
;
3028 var_1
= do_1
->ext
.iterator
->var
;
3029 var_2
= do_2
->ext
.iterator
->var
;
3030 var_3
= do_3
->ext
.iterator
->var
;
3034 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3038 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3042 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3047 u1
= get_size_m1 (matrix_b
, 1);
3048 u2
= get_size_m1 (matrix_a
, 1);
3050 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3051 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3053 do_1
->block
->next
= do_2
;
3054 do_2
->block
->next
= assign_matmul
;
3056 var_1
= do_1
->ext
.iterator
->var
;
3057 var_2
= do_2
->ext
.iterator
->var
;
3060 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3064 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3067 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3072 u1
= get_size_m1 (matrix_b
, 2);
3073 u2
= get_size_m1 (matrix_a
, 1);
3075 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3076 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3078 do_1
->block
->next
= do_2
;
3079 do_2
->block
->next
= assign_matmul
;
3081 var_1
= do_1
->ext
.iterator
->var
;
3082 var_2
= do_2
->ext
.iterator
->var
;
3085 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3088 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3092 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3101 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3102 matrix_a
->where
, 1, ascalar
);
3105 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3106 matrix_b
->where
, 1, bscalar
);
3108 /* First loop comes after the zero assignment. */
3109 assign_zero
->next
= do_1
;
3111 /* Build the assignment expression in the loop. */
3112 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3114 mult
= get_operand (op_times
, ascalar
, bscalar
);
3115 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3117 /* If we don't want to keep the original statement around in
3118 the else branch, we can free it. */
3120 if (if_limit
== NULL
)
3121 gfc_free_statements(co
);
3125 gfc_free_expr (zero
);
3130 #define WALK_SUBEXPR(NODE) \
3133 result = gfc_expr_walker (&(NODE), exprfn, data); \
3138 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3140 /* Walk expression *E, calling EXPRFN on each expression in it. */
3143 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3147 int walk_subtrees
= 1;
3148 gfc_actual_arglist
*a
;
3152 int result
= exprfn (e
, &walk_subtrees
, data
);
3156 switch ((*e
)->expr_type
)
3159 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3160 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3163 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3164 WALK_SUBEXPR (a
->expr
);
3168 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3169 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3170 WALK_SUBEXPR (a
->expr
);
3173 case EXPR_STRUCTURE
:
3175 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3176 c
= gfc_constructor_next (c
))
3178 if (c
->iterator
== NULL
)
3179 WALK_SUBEXPR (c
->expr
);
3183 WALK_SUBEXPR (c
->expr
);
3185 WALK_SUBEXPR (c
->iterator
->var
);
3186 WALK_SUBEXPR (c
->iterator
->start
);
3187 WALK_SUBEXPR (c
->iterator
->end
);
3188 WALK_SUBEXPR (c
->iterator
->step
);
3192 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3195 /* Fall through to the variable case in order to walk the
3198 case EXPR_SUBSTRING
:
3200 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3209 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3211 for (i
=0; i
< ar
->dimen
; i
++)
3213 WALK_SUBEXPR (ar
->start
[i
]);
3214 WALK_SUBEXPR (ar
->end
[i
]);
3215 WALK_SUBEXPR (ar
->stride
[i
]);
3222 WALK_SUBEXPR (r
->u
.ss
.start
);
3223 WALK_SUBEXPR (r
->u
.ss
.end
);
3239 #define WALK_SUBCODE(NODE) \
3242 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3248 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3249 on each expression in it. If any of the hooks returns non-zero, that
3250 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3251 no subcodes or subexpressions are traversed. */
3254 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3257 for (; *c
; c
= &(*c
)->next
)
3259 int walk_subtrees
= 1;
3260 int result
= codefn (c
, &walk_subtrees
, data
);
3267 gfc_actual_arglist
*a
;
3269 gfc_association_list
*alist
;
3270 bool saved_in_omp_workshare
;
3272 /* There might be statement insertions before the current code,
3273 which must not affect the expression walker. */
3276 saved_in_omp_workshare
= in_omp_workshare
;
3282 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3283 if (co
->ext
.block
.assoc
)
3285 bool saved_in_assoc_list
= in_assoc_list
;
3287 in_assoc_list
= true;
3288 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3289 WALK_SUBEXPR (alist
->target
);
3291 in_assoc_list
= saved_in_assoc_list
;
3298 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3299 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3300 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3301 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3305 case EXEC_ASSIGN_CALL
:
3306 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3307 WALK_SUBEXPR (a
->expr
);
3311 WALK_SUBEXPR (co
->expr1
);
3312 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3313 WALK_SUBEXPR (a
->expr
);
3317 WALK_SUBEXPR (co
->expr1
);
3318 for (b
= co
->block
; b
; b
= b
->block
)
3321 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3323 WALK_SUBEXPR (cp
->low
);
3324 WALK_SUBEXPR (cp
->high
);
3326 WALK_SUBCODE (b
->next
);
3331 case EXEC_DEALLOCATE
:
3334 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3335 WALK_SUBEXPR (a
->expr
);
3340 case EXEC_DO_CONCURRENT
:
3342 gfc_forall_iterator
*fa
;
3343 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3345 WALK_SUBEXPR (fa
->var
);
3346 WALK_SUBEXPR (fa
->start
);
3347 WALK_SUBEXPR (fa
->end
);
3348 WALK_SUBEXPR (fa
->stride
);
3350 if (co
->op
== EXEC_FORALL
)
3356 WALK_SUBEXPR (co
->ext
.open
->unit
);
3357 WALK_SUBEXPR (co
->ext
.open
->file
);
3358 WALK_SUBEXPR (co
->ext
.open
->status
);
3359 WALK_SUBEXPR (co
->ext
.open
->access
);
3360 WALK_SUBEXPR (co
->ext
.open
->form
);
3361 WALK_SUBEXPR (co
->ext
.open
->recl
);
3362 WALK_SUBEXPR (co
->ext
.open
->blank
);
3363 WALK_SUBEXPR (co
->ext
.open
->position
);
3364 WALK_SUBEXPR (co
->ext
.open
->action
);
3365 WALK_SUBEXPR (co
->ext
.open
->delim
);
3366 WALK_SUBEXPR (co
->ext
.open
->pad
);
3367 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3368 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3369 WALK_SUBEXPR (co
->ext
.open
->convert
);
3370 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3371 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3372 WALK_SUBEXPR (co
->ext
.open
->round
);
3373 WALK_SUBEXPR (co
->ext
.open
->sign
);
3374 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3375 WALK_SUBEXPR (co
->ext
.open
->id
);
3376 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3380 WALK_SUBEXPR (co
->ext
.close
->unit
);
3381 WALK_SUBEXPR (co
->ext
.close
->status
);
3382 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3383 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3386 case EXEC_BACKSPACE
:
3390 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3391 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3392 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3396 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3397 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3398 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3399 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3400 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3401 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3402 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3403 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3404 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3405 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3406 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3407 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3408 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3409 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3410 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3411 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3412 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3413 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3414 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3415 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3416 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3417 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3418 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3419 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3420 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3421 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3422 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3423 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3424 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3425 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3426 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3427 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3428 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3429 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3430 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3431 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3435 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3436 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3437 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3438 WALK_SUBEXPR (co
->ext
.wait
->id
);
3443 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3444 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3445 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3446 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3447 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3448 WALK_SUBEXPR (co
->ext
.dt
->size
);
3449 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3450 WALK_SUBEXPR (co
->ext
.dt
->id
);
3451 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3452 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3453 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3454 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3455 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3456 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3457 WALK_SUBEXPR (co
->ext
.dt
->round
);
3458 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3459 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3462 case EXEC_OMP_PARALLEL
:
3463 case EXEC_OMP_PARALLEL_DO
:
3464 case EXEC_OMP_PARALLEL_DO_SIMD
:
3465 case EXEC_OMP_PARALLEL_SECTIONS
:
3467 in_omp_workshare
= false;
3469 /* This goto serves as a shortcut to avoid code
3470 duplication or a larger if or switch statement. */
3471 goto check_omp_clauses
;
3473 case EXEC_OMP_WORKSHARE
:
3474 case EXEC_OMP_PARALLEL_WORKSHARE
:
3476 in_omp_workshare
= true;
3480 case EXEC_OMP_DISTRIBUTE
:
3481 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3482 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3483 case EXEC_OMP_DISTRIBUTE_SIMD
:
3485 case EXEC_OMP_DO_SIMD
:
3486 case EXEC_OMP_SECTIONS
:
3487 case EXEC_OMP_SINGLE
:
3488 case EXEC_OMP_END_SINGLE
:
3490 case EXEC_OMP_TARGET
:
3491 case EXEC_OMP_TARGET_DATA
:
3492 case EXEC_OMP_TARGET_TEAMS
:
3493 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3494 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3495 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3496 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3497 case EXEC_OMP_TARGET_UPDATE
:
3499 case EXEC_OMP_TEAMS
:
3500 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3501 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3502 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3503 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3505 /* Come to this label only from the
3506 EXEC_OMP_PARALLEL_* cases above. */
3510 if (co
->ext
.omp_clauses
)
3512 gfc_omp_namelist
*n
;
3513 static int list_types
[]
3514 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3515 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3517 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3518 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3519 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3520 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3521 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3522 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3523 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3524 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3525 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3526 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3528 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3530 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3532 WALK_SUBEXPR (n
->expr
);
3539 WALK_SUBEXPR (co
->expr1
);
3540 WALK_SUBEXPR (co
->expr2
);
3541 WALK_SUBEXPR (co
->expr3
);
3542 WALK_SUBEXPR (co
->expr4
);
3543 for (b
= co
->block
; b
; b
= b
->block
)
3545 WALK_SUBEXPR (b
->expr1
);
3546 WALK_SUBEXPR (b
->expr2
);
3547 WALK_SUBCODE (b
->next
);
3550 if (co
->op
== EXEC_FORALL
)
3553 if (co
->op
== EXEC_DO
)
3556 in_omp_workshare
= saved_in_omp_workshare
;