1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2016 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static void optimize_reduction (gfc_namespace
*);
43 static int callback_reduction (gfc_expr
**, int *, void *);
44 static void realloc_strings (gfc_namespace
*);
45 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
46 static int inline_matmul_assign (gfc_code
**, int *, void *);
47 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
48 locus
*, gfc_namespace
*,
51 /* How deep we are inside an argument list. */
53 static int count_arglist
;
55 /* Vector of gfc_expr ** we operate on. */
57 static vec
<gfc_expr
**> expr_array
;
59 /* Pointer to the gfc_code we currently work on - to be able to insert
60 a block before the statement. */
62 static gfc_code
**current_code
;
64 /* Pointer to the block to be inserted, and the statement we are
65 changing within the block. */
67 static gfc_code
*inserted_block
, **changed_statement
;
69 /* The namespace we are currently dealing with. */
71 static gfc_namespace
*current_ns
;
73 /* If we are within any forall loop. */
75 static int forall_level
;
77 /* Keep track of whether we are within an OMP workshare. */
79 static bool in_omp_workshare
;
81 /* Keep track of whether we are within a WHERE statement. */
85 /* Keep track of iterators for array constructors. */
87 static int iterator_level
;
89 /* Keep track of DO loop levels. */
91 static vec
<gfc_code
*> doloop_list
;
93 static int doloop_level
;
95 /* Vector of gfc_expr * to keep track of DO loops. */
97 struct my_struct
*evec
;
99 /* Keep track of association lists. */
101 static bool in_assoc_list
;
103 /* Counter for temporary variables. */
105 static int var_num
= 1;
107 /* What sort of matrix we are dealing with when inlining MATMUL. */
109 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
};
111 /* Keep track of the number of expressions we have inserted so far
116 /* Entry point - run all passes for a namespace. */
119 gfc_run_passes (gfc_namespace
*ns
)
122 /* Warn about dubious DO loops where the index might
127 doloop_list
.release ();
130 if (flag_frontend_optimize
)
132 optimize_namespace (ns
);
133 optimize_reduction (ns
);
134 if (flag_dump_fortran_optimized
)
135 gfc_dump_parse_tree (ns
, stdout
);
137 expr_array
.release ();
140 gfc_get_errors (&w
, &e
);
144 if (flag_realloc_lhs
)
145 realloc_strings (ns
);
148 /* Callback for each gfc_code node invoked from check_realloc_strings.
149 For an allocatable LHS string which also appears as a variable on
161 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
162 void *data ATTRIBUTE_UNUSED
)
164 gfc_expr
*expr1
, *expr2
;
170 if (co
->op
!= EXEC_ASSIGN
)
174 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
175 || !gfc_expr_attr(expr1
).allocatable
176 || !expr1
->ts
.deferred
)
179 expr2
= gfc_discard_nops (co
->expr2
);
180 if (expr2
->expr_type
!= EXPR_VARIABLE
)
183 found_substr
= false;
184 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
186 if (ref
->type
== REF_SUBSTRING
)
195 if (!gfc_check_dependency (expr1
, expr2
, true))
198 /* gfc_check_dependency doesn't always pick up identical expressions.
199 However, eliminating the above sends the compiler into an infinite
200 loop on valid expressions. Without this check, the gimplifier emits
201 an ICE for a = a, where a is deferred character length. */
202 if (!gfc_dep_compare_expr (expr1
, expr2
))
206 inserted_block
= NULL
;
207 changed_statement
= NULL
;
208 n
= create_var (expr2
, "realloc_string");
213 /* Callback for each gfc_code node invoked through gfc_code_walker
214 from optimize_namespace. */
217 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
218 void *data ATTRIBUTE_UNUSED
)
225 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
226 || op
== EXEC_CALL_PPC
)
232 inserted_block
= NULL
;
233 changed_statement
= NULL
;
235 if (op
== EXEC_ASSIGN
)
236 optimize_assignment (*c
);
240 /* Callback for each gfc_expr node invoked through gfc_code_walker
241 from optimize_namespace. */
244 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
245 void *data ATTRIBUTE_UNUSED
)
249 if ((*e
)->expr_type
== EXPR_FUNCTION
)
252 function_expr
= true;
255 function_expr
= false;
257 if (optimize_trim (*e
))
258 gfc_simplify_expr (*e
, 0);
260 if (optimize_lexical_comparison (*e
))
261 gfc_simplify_expr (*e
, 0);
263 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
264 gfc_simplify_expr (*e
, 0);
266 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
267 switch ((*e
)->value
.function
.isym
->id
)
269 case GFC_ISYM_MINLOC
:
270 case GFC_ISYM_MAXLOC
:
271 optimize_minmaxloc (e
);
283 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
284 function is a scalar, just copy it; otherwise returns the new element, the
285 old one can be freed. */
288 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
290 gfc_expr
*fcn
, *e
= c
->expr
;
292 fcn
= gfc_copy_expr (e
);
295 gfc_constructor_base newbase
;
297 gfc_constructor
*new_c
;
300 new_expr
= gfc_get_expr ();
301 new_expr
->expr_type
= EXPR_ARRAY
;
302 new_expr
->ts
= e
->ts
;
303 new_expr
->where
= e
->where
;
305 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
306 new_c
->iterator
= c
->iterator
;
307 new_expr
->value
.constructor
= newbase
;
315 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
317 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
318 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
319 fn
->value
.function
.isym
->name
,
320 fn
->where
, 3, fcn
, NULL
, NULL
);
321 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
322 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
323 fn
->value
.function
.isym
->name
,
324 fn
->where
, 2, fcn
, NULL
);
326 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
328 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
334 /* Callback function for optimzation of reductions to scalars. Transform ANY
335 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
336 correspondingly. Handly only the simple cases without MASK and DIM. */
339 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
340 void *data ATTRIBUTE_UNUSED
)
345 gfc_actual_arglist
*a
;
346 gfc_actual_arglist
*dim
;
348 gfc_expr
*res
, *new_expr
;
349 gfc_actual_arglist
*mask
;
353 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
354 || fn
->value
.function
.isym
== NULL
)
357 id
= fn
->value
.function
.isym
->id
;
359 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
360 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
363 a
= fn
->value
.function
.actual
;
365 /* Don't handle MASK or DIM. */
369 if (dim
->expr
!= NULL
)
372 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
375 if ( mask
->expr
!= NULL
)
381 if (arg
->expr_type
!= EXPR_ARRAY
)
390 case GFC_ISYM_PRODUCT
:
391 op
= INTRINSIC_TIMES
;
406 c
= gfc_constructor_first (arg
->value
.constructor
);
408 /* Don't do any simplififcation if we have
409 - no element in the constructor or
410 - only have a single element in the array which contains an
416 res
= copy_walk_reduction_arg (c
, fn
);
418 c
= gfc_constructor_next (c
);
421 new_expr
= gfc_get_expr ();
422 new_expr
->ts
= fn
->ts
;
423 new_expr
->expr_type
= EXPR_OP
;
424 new_expr
->rank
= fn
->rank
;
425 new_expr
->where
= fn
->where
;
426 new_expr
->value
.op
.op
= op
;
427 new_expr
->value
.op
.op1
= res
;
428 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
430 c
= gfc_constructor_next (c
);
433 gfc_simplify_expr (res
, 0);
440 /* Callback function for common function elimination, called from cfe_expr_0.
441 Put all eligible function expressions into expr_array. */
444 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
445 void *data ATTRIBUTE_UNUSED
)
448 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
451 /* We don't do character functions with unknown charlens. */
452 if ((*e
)->ts
.type
== BT_CHARACTER
453 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
454 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
457 /* We don't do function elimination within FORALL statements, it can
458 lead to wrong-code in certain circumstances. */
460 if (forall_level
> 0)
463 /* Function elimination inside an iterator could lead to functions which
464 depend on iterator variables being moved outside. FIXME: We should check
465 if the functions do indeed depend on the iterator variable. */
467 if (iterator_level
> 0)
470 /* If we don't know the shape at compile time, we create an allocatable
471 temporary variable to hold the intermediate result, but only if
472 allocation on assignment is active. */
474 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
477 /* Skip the test for pure functions if -faggressive-function-elimination
479 if ((*e
)->value
.function
.esym
)
481 /* Don't create an array temporary for elemental functions. */
482 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
485 /* Only eliminate potentially impure functions if the
486 user specifically requested it. */
487 if (!flag_aggressive_function_elimination
488 && !(*e
)->value
.function
.esym
->attr
.pure
489 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
493 if ((*e
)->value
.function
.isym
)
495 /* Conversions are handled on the fly by the middle end,
496 transpose during trans-* stages and TRANSFER by the middle end. */
497 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
498 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
499 || gfc_inline_intrinsic_function_p (*e
))
502 /* Don't create an array temporary for elemental functions,
503 as this would be wasteful of memory.
504 FIXME: Create a scalar temporary during scalarization. */
505 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
508 if (!(*e
)->value
.function
.isym
->pure
)
512 expr_array
.safe_push (e
);
516 /* Auxiliary function to check if an expression is a temporary created by
520 is_fe_temp (gfc_expr
*e
)
522 if (e
->expr_type
!= EXPR_VARIABLE
)
525 return e
->symtree
->n
.sym
->attr
.fe_temp
;
528 /* Determine the length of a string, if it can be evaluated as a constant
529 expression. Return a newly allocated gfc_expr or NULL on failure.
530 If the user specified a substring which is potentially longer than
531 the string itself, the string will be padded with spaces, which
535 constant_string_length (gfc_expr
*e
)
545 length
= e
->ts
.u
.cl
->length
;
546 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
547 return gfc_copy_expr(length
);
550 /* Return length of substring, if constant. */
551 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
553 if (ref
->type
== REF_SUBSTRING
554 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
556 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
559 mpz_add_ui (res
->value
.integer
, value
, 1);
565 /* Return length of char symbol, if constant. */
567 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
568 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
569 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
575 /* Insert a block at the current position unless it has already
576 been inserted; in this case use the one already there. */
578 static gfc_namespace
*
583 /* If the block hasn't already been created, do so. */
584 if (inserted_block
== NULL
)
586 inserted_block
= XCNEW (gfc_code
);
587 inserted_block
->op
= EXEC_BLOCK
;
588 inserted_block
->loc
= (*current_code
)->loc
;
589 ns
= gfc_build_block_ns (current_ns
);
590 inserted_block
->ext
.block
.ns
= ns
;
591 inserted_block
->ext
.block
.assoc
= NULL
;
593 ns
->code
= *current_code
;
595 /* If the statement has a label, make sure it is transferred to
596 the newly created block. */
598 if ((*current_code
)->here
)
600 inserted_block
->here
= (*current_code
)->here
;
601 (*current_code
)->here
= NULL
;
604 inserted_block
->next
= (*current_code
)->next
;
605 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
606 (*current_code
)->next
= NULL
;
607 /* Insert the BLOCK at the right position. */
608 *current_code
= inserted_block
;
609 ns
->parent
= current_ns
;
612 ns
= inserted_block
->ext
.block
.ns
;
617 /* Returns a new expression (a variable) to be used in place of the old one,
618 with an optional assignment statement before the current statement to set
619 the value of the variable. Creates a new BLOCK for the statement if that
620 hasn't already been done and puts the statement, plus the newly created
621 variables, in that block. Special cases: If the expression is constant or
622 a temporary which has already been created, just copy it. */
625 create_var (gfc_expr
* e
, const char *vname
)
627 char name
[GFC_MAX_SYMBOL_LEN
+1];
628 gfc_symtree
*symtree
;
636 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
637 return gfc_copy_expr (e
);
639 ns
= insert_block ();
642 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
644 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
646 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
649 symbol
= symtree
->n
.sym
;
654 symbol
->as
= gfc_get_array_spec ();
655 symbol
->as
->rank
= e
->rank
;
657 if (e
->shape
== NULL
)
659 /* We don't know the shape at compile time, so we use an
661 symbol
->as
->type
= AS_DEFERRED
;
662 symbol
->attr
.allocatable
= 1;
666 symbol
->as
->type
= AS_EXPLICIT
;
667 /* Copy the shape. */
668 for (i
=0; i
<e
->rank
; i
++)
672 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
674 mpz_set_si (p
->value
.integer
, 1);
675 symbol
->as
->lower
[i
] = p
;
677 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
679 mpz_set (q
->value
.integer
, e
->shape
[i
]);
680 symbol
->as
->upper
[i
] = q
;
686 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
690 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
691 length
= constant_string_length (e
);
693 symbol
->ts
.u
.cl
->length
= length
;
696 symbol
->attr
.allocatable
= 1;
701 symbol
->attr
.flavor
= FL_VARIABLE
;
702 symbol
->attr
.referenced
= 1;
703 symbol
->attr
.dimension
= e
->rank
> 0;
704 symbol
->attr
.fe_temp
= 1;
705 gfc_commit_symbol (symbol
);
707 result
= gfc_get_expr ();
708 result
->expr_type
= EXPR_VARIABLE
;
710 result
->ts
.deferred
= deferred
;
711 result
->rank
= e
->rank
;
712 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
713 result
->symtree
= symtree
;
714 result
->where
= e
->where
;
717 result
->ref
= gfc_get_ref ();
718 result
->ref
->type
= REF_ARRAY
;
719 result
->ref
->u
.ar
.type
= AR_FULL
;
720 result
->ref
->u
.ar
.where
= e
->where
;
721 result
->ref
->u
.ar
.dimen
= e
->rank
;
722 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
723 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
724 if (warn_array_temporaries
)
725 gfc_warning (OPT_Warray_temporaries
,
726 "Creating array temporary at %L", &(e
->where
));
729 /* Generate the new assignment. */
730 n
= XCNEW (gfc_code
);
732 n
->loc
= (*current_code
)->loc
;
733 n
->next
= *changed_statement
;
734 n
->expr1
= gfc_copy_expr (result
);
736 *changed_statement
= n
;
742 /* Warn about function elimination. */
745 do_warn_function_elimination (gfc_expr
*e
)
747 if (e
->expr_type
!= EXPR_FUNCTION
)
749 if (e
->value
.function
.esym
)
750 gfc_warning (0, "Removing call to function %qs at %L",
751 e
->value
.function
.esym
->name
, &(e
->where
));
752 else if (e
->value
.function
.isym
)
753 gfc_warning (0, "Removing call to function %qs at %L",
754 e
->value
.function
.isym
->name
, &(e
->where
));
756 /* Callback function for the code walker for doing common function
757 elimination. This builds up the list of functions in the expression
758 and goes through them to detect duplicates, which it then replaces
762 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
763 void *data ATTRIBUTE_UNUSED
)
769 /* Don't do this optimization within OMP workshare or ASSOC lists. */
771 if (in_omp_workshare
|| in_assoc_list
)
777 expr_array
.release ();
779 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
781 /* Walk through all the functions. */
783 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
785 /* Skip if the function has been replaced by a variable already. */
786 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
793 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
796 newvar
= create_var (*ei
, "fcn");
798 if (warn_function_elimination
)
799 do_warn_function_elimination (*ej
);
802 *ej
= gfc_copy_expr (newvar
);
809 /* We did all the necessary walking in this function. */
814 /* Callback function for common function elimination, called from
815 gfc_code_walker. This keeps track of the current code, in order
816 to insert statements as needed. */
819 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
822 inserted_block
= NULL
;
823 changed_statement
= NULL
;
825 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
826 and allocation on assigment are prohibited inside WHERE, and finally
827 masking an expression would lead to wrong-code when replacing
830 b = sum(foo(a) + foo(a))
841 if ((*c
)->op
== EXEC_WHERE
)
851 /* Dummy function for expression call back, for use when we
852 really don't want to do any walking. */
855 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
856 void *data ATTRIBUTE_UNUSED
)
862 /* Dummy function for code callback, for use when we really
863 don't want to do anything. */
865 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
866 int *walk_subtrees ATTRIBUTE_UNUSED
,
867 void *data ATTRIBUTE_UNUSED
)
872 /* Code callback function for converting
879 This is because common function elimination would otherwise place the
880 temporary variables outside the loop. */
883 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
884 void *data ATTRIBUTE_UNUSED
)
887 gfc_code
*c_if1
, *c_if2
, *c_exit
;
889 gfc_expr
*e_not
, *e_cond
;
891 if (co
->op
!= EXEC_DO_WHILE
)
894 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
899 /* Generate the condition of the if statement, which is .not. the original
901 e_not
= gfc_get_expr ();
902 e_not
->ts
= e_cond
->ts
;
903 e_not
->where
= e_cond
->where
;
904 e_not
->expr_type
= EXPR_OP
;
905 e_not
->value
.op
.op
= INTRINSIC_NOT
;
906 e_not
->value
.op
.op1
= e_cond
;
908 /* Generate the EXIT statement. */
909 c_exit
= XCNEW (gfc_code
);
910 c_exit
->op
= EXEC_EXIT
;
911 c_exit
->ext
.which_construct
= co
;
912 c_exit
->loc
= co
->loc
;
914 /* Generate the IF statement. */
915 c_if2
= XCNEW (gfc_code
);
917 c_if2
->expr1
= e_not
;
918 c_if2
->next
= c_exit
;
919 c_if2
->loc
= co
->loc
;
921 /* ... plus the one to chain it to. */
922 c_if1
= XCNEW (gfc_code
);
924 c_if1
->block
= c_if2
;
925 c_if1
->loc
= co
->loc
;
927 /* Make the DO WHILE loop into a DO block by replacing the condition
928 with a true constant. */
929 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
931 /* Hang the generated if statement into the loop body. */
933 loopblock
= co
->block
->next
;
934 co
->block
->next
= c_if1
;
935 c_if1
->next
= loopblock
;
940 /* Code callback function for converting
953 because otherwise common function elimination would place the BLOCKs
954 into the wrong place. */
957 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
958 void *data ATTRIBUTE_UNUSED
)
961 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
963 if (co
->op
!= EXEC_IF
)
966 /* This loop starts out with the first ELSE statement. */
967 else_stmt
= co
->block
->block
;
969 while (else_stmt
!= NULL
)
973 /* If there is no condition, we're done. */
974 if (else_stmt
->expr1
== NULL
)
977 next_else
= else_stmt
->block
;
979 /* Generate the new IF statement. */
980 c_if2
= XCNEW (gfc_code
);
982 c_if2
->expr1
= else_stmt
->expr1
;
983 c_if2
->next
= else_stmt
->next
;
984 c_if2
->loc
= else_stmt
->loc
;
985 c_if2
->block
= next_else
;
987 /* ... plus the one to chain it to. */
988 c_if1
= XCNEW (gfc_code
);
990 c_if1
->block
= c_if2
;
991 c_if1
->loc
= else_stmt
->loc
;
993 /* Insert the new IF after the ELSE. */
994 else_stmt
->expr1
= NULL
;
995 else_stmt
->next
= c_if1
;
996 else_stmt
->block
= NULL
;
998 else_stmt
= next_else
;
1000 /* Don't walk subtrees. */
1004 /* Optimize a namespace, including all contained namespaces. */
1007 optimize_namespace (gfc_namespace
*ns
)
1009 gfc_namespace
*saved_ns
= gfc_current_ns
;
1011 gfc_current_ns
= ns
;
1014 in_assoc_list
= false;
1015 in_omp_workshare
= false;
1017 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1018 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1019 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1020 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1021 if (flag_inline_matmul_limit
!= 0)
1022 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1025 /* BLOCKs are handled in the expression walker below. */
1026 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1028 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1029 optimize_namespace (ns
);
1031 gfc_current_ns
= saved_ns
;
1034 /* Handle dependencies for allocatable strings which potentially redefine
1035 themselves in an assignment. */
1038 realloc_strings (gfc_namespace
*ns
)
1041 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1043 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1045 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1046 realloc_strings (ns
);
1052 optimize_reduction (gfc_namespace
*ns
)
1055 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1056 callback_reduction
, NULL
);
1058 /* BLOCKs are handled in the expression walker below. */
1059 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1061 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1062 optimize_reduction (ns
);
1066 /* Replace code like
1069 a = matmul(b,c) ; a = a + d
1070 where the array function is not elemental and not allocatable
1071 and does not depend on the left-hand side.
1075 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1080 if (e
->expr_type
== EXPR_OP
)
1082 switch (e
->value
.op
.op
)
1084 /* Unary operators and exponentiation: Only look at a single
1087 case INTRINSIC_UPLUS
:
1088 case INTRINSIC_UMINUS
:
1089 case INTRINSIC_PARENTHESES
:
1090 case INTRINSIC_POWER
:
1091 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1095 case INTRINSIC_CONCAT
:
1096 /* Do not do string concatenations. */
1100 /* Binary operators. */
1101 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1104 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1110 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1111 && ! (e
->value
.function
.esym
1112 && (e
->value
.function
.esym
->attr
.elemental
1113 || e
->value
.function
.esym
->attr
.allocatable
1114 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1115 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1116 && ! (e
->value
.function
.isym
1117 && (e
->value
.function
.isym
->elemental
1118 || e
->ts
.type
!= c
->expr1
->ts
.type
1119 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1120 && ! gfc_inline_intrinsic_function_p (e
))
1126 /* Insert a new assignment statement after the current one. */
1127 n
= XCNEW (gfc_code
);
1128 n
->op
= EXEC_ASSIGN
;
1133 n
->expr1
= gfc_copy_expr (c
->expr1
);
1134 n
->expr2
= c
->expr2
;
1135 new_expr
= gfc_copy_expr (c
->expr1
);
1143 /* Nothing to optimize. */
1147 /* Remove unneeded TRIMs at the end of expressions. */
1150 remove_trim (gfc_expr
*rhs
)
1158 /* Check for a // b // trim(c). Looping is probably not
1159 necessary because the parser usually generates
1160 (// (// a b ) trim(c) ) , but better safe than sorry. */
1162 while (rhs
->expr_type
== EXPR_OP
1163 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1164 rhs
= rhs
->value
.op
.op2
;
1166 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1167 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1169 strip_function_call (rhs
);
1170 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1178 /* Optimizations for an assignment. */
1181 optimize_assignment (gfc_code
* c
)
1183 gfc_expr
*lhs
, *rhs
;
1188 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1190 /* Optimize a = trim(b) to a = b. */
1193 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1194 if (is_empty_string (rhs
))
1195 rhs
->value
.character
.length
= 0;
1198 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1199 optimize_binop_array_assignment (c
, &rhs
, false);
1203 /* Remove an unneeded function call, modifying the expression.
1204 This replaces the function call with the value of its
1205 first argument. The rest of the argument list is freed. */
1208 strip_function_call (gfc_expr
*e
)
1211 gfc_actual_arglist
*a
;
1213 a
= e
->value
.function
.actual
;
1215 /* We should have at least one argument. */
1216 gcc_assert (a
->expr
!= NULL
);
1220 /* Free the remaining arglist, if any. */
1222 gfc_free_actual_arglist (a
->next
);
1224 /* Graft the argument expression onto the original function. */
1230 /* Optimization of lexical comparison functions. */
1233 optimize_lexical_comparison (gfc_expr
*e
)
1235 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1238 switch (e
->value
.function
.isym
->id
)
1241 return optimize_comparison (e
, INTRINSIC_LE
);
1244 return optimize_comparison (e
, INTRINSIC_GE
);
1247 return optimize_comparison (e
, INTRINSIC_GT
);
1250 return optimize_comparison (e
, INTRINSIC_LT
);
1258 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1259 do CHARACTER because of possible pessimization involving character
1263 combine_array_constructor (gfc_expr
*e
)
1266 gfc_expr
*op1
, *op2
;
1269 gfc_constructor
*c
, *new_c
;
1270 gfc_constructor_base oldbase
, newbase
;
1273 /* Array constructors have rank one. */
1277 /* Don't try to combine association lists, this makes no sense
1278 and leads to an ICE. */
1282 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1283 if (forall_level
> 0)
1286 /* Inside an iterator, things can get hairy; we are likely to create
1287 an invalid temporary variable. */
1288 if (iterator_level
> 0)
1291 op1
= e
->value
.op
.op1
;
1292 op2
= e
->value
.op
.op2
;
1297 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1298 scalar_first
= false;
1299 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1301 scalar_first
= true;
1302 op1
= e
->value
.op
.op2
;
1303 op2
= e
->value
.op
.op1
;
1308 if (op2
->ts
.type
== BT_CHARACTER
)
1311 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1313 oldbase
= op1
->value
.constructor
;
1315 e
->expr_type
= EXPR_ARRAY
;
1317 for (c
= gfc_constructor_first (oldbase
); c
;
1318 c
= gfc_constructor_next (c
))
1320 new_expr
= gfc_get_expr ();
1321 new_expr
->ts
= e
->ts
;
1322 new_expr
->expr_type
= EXPR_OP
;
1323 new_expr
->rank
= c
->expr
->rank
;
1324 new_expr
->where
= c
->where
;
1325 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1329 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1330 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1334 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1335 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1338 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1339 new_c
->iterator
= c
->iterator
;
1343 gfc_free_expr (op1
);
1344 gfc_free_expr (op2
);
1345 gfc_free_expr (scalar
);
1347 e
->value
.constructor
= newbase
;
1351 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1352 2**k into ishift(1,k) */
1355 optimize_power (gfc_expr
*e
)
1357 gfc_expr
*op1
, *op2
;
1358 gfc_expr
*iand
, *ishft
;
1360 if (e
->ts
.type
!= BT_INTEGER
)
1363 op1
= e
->value
.op
.op1
;
1365 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1368 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1370 gfc_free_expr (op1
);
1372 op2
= e
->value
.op
.op2
;
1377 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1378 "_internal_iand", e
->where
, 2, op2
,
1379 gfc_get_int_expr (e
->ts
.kind
,
1382 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1383 "_internal_ishft", e
->where
, 2, iand
,
1384 gfc_get_int_expr (e
->ts
.kind
,
1387 e
->value
.op
.op
= INTRINSIC_MINUS
;
1388 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1389 e
->value
.op
.op2
= ishft
;
1392 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1394 gfc_free_expr (op1
);
1396 op2
= e
->value
.op
.op2
;
1400 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1401 "_internal_ishft", e
->where
, 2,
1402 gfc_get_int_expr (e
->ts
.kind
,
1409 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1411 op2
= e
->value
.op
.op2
;
1415 gfc_free_expr (op1
);
1416 gfc_free_expr (op2
);
1418 e
->expr_type
= EXPR_CONSTANT
;
1419 e
->value
.op
.op1
= NULL
;
1420 e
->value
.op
.op2
= NULL
;
1421 mpz_init_set_si (e
->value
.integer
, 1);
1422 /* Typespec and location are still OK. */
1429 /* Recursive optimization of operators. */
1432 optimize_op (gfc_expr
*e
)
1436 gfc_intrinsic_op op
= e
->value
.op
.op
;
1440 /* Only use new-style comparisons. */
1443 case INTRINSIC_EQ_OS
:
1447 case INTRINSIC_GE_OS
:
1451 case INTRINSIC_LE_OS
:
1455 case INTRINSIC_NE_OS
:
1459 case INTRINSIC_GT_OS
:
1463 case INTRINSIC_LT_OS
:
1479 changed
= optimize_comparison (e
, op
);
1482 /* Look at array constructors. */
1483 case INTRINSIC_PLUS
:
1484 case INTRINSIC_MINUS
:
1485 case INTRINSIC_TIMES
:
1486 case INTRINSIC_DIVIDE
:
1487 return combine_array_constructor (e
) || changed
;
1489 case INTRINSIC_POWER
:
1490 return optimize_power (e
);
1501 /* Return true if a constant string contains only blanks. */
1504 is_empty_string (gfc_expr
*e
)
1508 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1511 for (i
=0; i
< e
->value
.character
.length
; i
++)
1513 if (e
->value
.character
.string
[i
] != ' ')
1521 /* Insert a call to the intrinsic len_trim. Use a different name for
1522 the symbol tree so we don't run into trouble when the user has
1523 renamed len_trim for some reason. */
1526 get_len_trim_call (gfc_expr
*str
, int kind
)
1529 gfc_actual_arglist
*actual_arglist
, *next
;
1531 fcn
= gfc_get_expr ();
1532 fcn
->expr_type
= EXPR_FUNCTION
;
1533 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1534 actual_arglist
= gfc_get_actual_arglist ();
1535 actual_arglist
->expr
= str
;
1536 next
= gfc_get_actual_arglist ();
1537 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1538 actual_arglist
->next
= next
;
1540 fcn
->value
.function
.actual
= actual_arglist
;
1541 fcn
->where
= str
->where
;
1542 fcn
->ts
.type
= BT_INTEGER
;
1543 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1545 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1546 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1547 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1548 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1549 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1550 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1551 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1552 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1557 /* Optimize expressions for equality. */
1560 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1562 gfc_expr
*op1
, *op2
;
1566 gfc_actual_arglist
*firstarg
, *secondarg
;
1568 if (e
->expr_type
== EXPR_OP
)
1572 op1
= e
->value
.op
.op1
;
1573 op2
= e
->value
.op
.op2
;
1575 else if (e
->expr_type
== EXPR_FUNCTION
)
1577 /* One of the lexical comparison functions. */
1578 firstarg
= e
->value
.function
.actual
;
1579 secondarg
= firstarg
->next
;
1580 op1
= firstarg
->expr
;
1581 op2
= secondarg
->expr
;
1586 /* Strip off unneeded TRIM calls from string comparisons. */
1588 change
= remove_trim (op1
);
1590 if (remove_trim (op2
))
1593 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1594 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1595 handles them well). However, there are also cases that need a non-scalar
1596 argument. For example the any intrinsic. See PR 45380. */
1600 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1602 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1603 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1605 bool empty_op1
, empty_op2
;
1606 empty_op1
= is_empty_string (op1
);
1607 empty_op2
= is_empty_string (op2
);
1609 if (empty_op1
|| empty_op2
)
1615 /* This can only happen when an error for comparing
1616 characters of different kinds has already been issued. */
1617 if (empty_op1
&& empty_op2
)
1620 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1621 str
= empty_op1
? op2
: op1
;
1623 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1627 gfc_free_expr (op1
);
1629 gfc_free_expr (op2
);
1633 e
->value
.op
.op1
= fcn
;
1634 e
->value
.op
.op2
= zero
;
1639 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1641 if (flag_finite_math_only
1642 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1643 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1645 eq
= gfc_dep_compare_expr (op1
, op2
);
1648 /* Replace A // B < A // C with B < C, and A // B < C // B
1650 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1651 && op1
->expr_type
== EXPR_OP
1652 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1653 && op2
->expr_type
== EXPR_OP
1654 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1656 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1657 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1658 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1659 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1661 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1663 /* Watch out for 'A ' // x vs. 'A' // x. */
1665 if (op1_left
->expr_type
== EXPR_CONSTANT
1666 && op2_left
->expr_type
== EXPR_CONSTANT
1667 && op1_left
->value
.character
.length
1668 != op2_left
->value
.character
.length
)
1676 firstarg
->expr
= op1_right
;
1677 secondarg
->expr
= op2_right
;
1681 e
->value
.op
.op1
= op1_right
;
1682 e
->value
.op
.op2
= op2_right
;
1684 optimize_comparison (e
, op
);
1688 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1694 firstarg
->expr
= op1_left
;
1695 secondarg
->expr
= op2_left
;
1699 e
->value
.op
.op1
= op1_left
;
1700 e
->value
.op
.op2
= op2_left
;
1703 optimize_comparison (e
, op
);
1710 /* eq can only be -1, 0 or 1 at this point. */
1738 gfc_internal_error ("illegal OP in optimize_comparison");
1742 /* Replace the expression by a constant expression. The typespec
1743 and where remains the way it is. */
1746 e
->expr_type
= EXPR_CONSTANT
;
1747 e
->value
.logical
= result
;
1755 /* Optimize a trim function by replacing it with an equivalent substring
1756 involving a call to len_trim. This only works for expressions where
1757 variables are trimmed. Return true if anything was modified. */
1760 optimize_trim (gfc_expr
*e
)
1765 gfc_ref
**rr
= NULL
;
1767 /* Don't do this optimization within an argument list, because
1768 otherwise aliasing issues may occur. */
1770 if (count_arglist
!= 1)
1773 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1774 || e
->value
.function
.isym
== NULL
1775 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1778 a
= e
->value
.function
.actual
->expr
;
1780 if (a
->expr_type
!= EXPR_VARIABLE
)
1783 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1785 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1788 /* Follow all references to find the correct place to put the newly
1789 created reference. FIXME: Also handle substring references and
1790 array references. Array references cause strange regressions at
1795 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1797 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1802 strip_function_call (e
);
1807 /* Create the reference. */
1809 ref
= gfc_get_ref ();
1810 ref
->type
= REF_SUBSTRING
;
1812 /* Set the start of the reference. */
1814 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1816 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1818 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1820 /* Set the end of the reference to the call to len_trim. */
1822 ref
->u
.ss
.end
= fcn
;
1823 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1828 /* Optimize minloc(b), where b is rank 1 array, into
1829 (/ minloc(b, dim=1) /), and similarly for maxloc,
1830 as the latter forms are expanded inline. */
1833 optimize_minmaxloc (gfc_expr
**e
)
1836 gfc_actual_arglist
*a
;
1840 || fn
->value
.function
.actual
== NULL
1841 || fn
->value
.function
.actual
->expr
== NULL
1842 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1845 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1846 (*e
)->shape
= fn
->shape
;
1849 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1851 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1852 strcpy (name
, fn
->value
.function
.name
);
1853 p
= strstr (name
, "loc0");
1855 fn
->value
.function
.name
= gfc_get_string (name
);
1856 if (fn
->value
.function
.actual
->next
)
1858 a
= fn
->value
.function
.actual
->next
;
1859 gcc_assert (a
->expr
== NULL
);
1863 a
= gfc_get_actual_arglist ();
1864 fn
->value
.function
.actual
->next
= a
;
1866 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1868 mpz_set_ui (a
->expr
->value
.integer
, 1);
1871 /* Callback function for code checking that we do not pass a DO variable to an
1872 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1875 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1876 void *data ATTRIBUTE_UNUSED
)
1880 gfc_formal_arglist
*f
;
1881 gfc_actual_arglist
*a
;
1886 /* If the doloop_list grew, we have to truncate it here. */
1888 if ((unsigned) doloop_level
< doloop_list
.length())
1889 doloop_list
.truncate (doloop_level
);
1895 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1896 doloop_list
.safe_push (co
);
1898 doloop_list
.safe_push ((gfc_code
*) NULL
);
1903 if (co
->resolved_sym
== NULL
)
1906 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1908 /* Withot a formal arglist, there is only unknown INTENT,
1909 which we don't check for. */
1917 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1924 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1926 if (a
->expr
&& a
->expr
->symtree
1927 && a
->expr
->symtree
->n
.sym
== do_sym
)
1929 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1930 gfc_error_now ("Variable %qs at %L set to undefined "
1931 "value inside loop beginning at %L as "
1932 "INTENT(OUT) argument to subroutine %qs",
1933 do_sym
->name
, &a
->expr
->where
,
1934 &doloop_list
[i
]->loc
,
1935 co
->symtree
->n
.sym
->name
);
1936 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1937 gfc_error_now ("Variable %qs at %L not definable inside "
1938 "loop beginning at %L as INTENT(INOUT) "
1939 "argument to subroutine %qs",
1940 do_sym
->name
, &a
->expr
->where
,
1941 &doloop_list
[i
]->loc
,
1942 co
->symtree
->n
.sym
->name
);
1956 /* Callback function for functions checking that we do not pass a DO variable
1957 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1960 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1961 void *data ATTRIBUTE_UNUSED
)
1963 gfc_formal_arglist
*f
;
1964 gfc_actual_arglist
*a
;
1970 if (expr
->expr_type
!= EXPR_FUNCTION
)
1973 /* Intrinsic functions don't modify their arguments. */
1975 if (expr
->value
.function
.isym
)
1978 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1980 /* Without a formal arglist, there is only unknown INTENT,
1981 which we don't check for. */
1985 a
= expr
->value
.function
.actual
;
1989 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1996 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
1998 if (a
->expr
&& a
->expr
->symtree
1999 && a
->expr
->symtree
->n
.sym
== do_sym
)
2001 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2002 gfc_error_now ("Variable %qs at %L set to undefined value "
2003 "inside loop beginning at %L as INTENT(OUT) "
2004 "argument to function %qs", do_sym
->name
,
2005 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2006 expr
->symtree
->n
.sym
->name
);
2007 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2008 gfc_error_now ("Variable %qs at %L not definable inside loop"
2009 " beginning at %L as INTENT(INOUT) argument to"
2010 " function %qs", do_sym
->name
,
2011 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2012 expr
->symtree
->n
.sym
->name
);
2023 doloop_warn (gfc_namespace
*ns
)
2025 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2028 /* This selction deals with inlining calls to MATMUL. */
2030 /* Auxiliary function to build and simplify an array inquiry function.
2031 dim is zero-based. */
2034 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2037 gfc_expr
*dim_arg
, *kind
;
2043 case GFC_ISYM_LBOUND
:
2044 name
= "_gfortran_lbound";
2047 case GFC_ISYM_UBOUND
:
2048 name
= "_gfortran_ubound";
2052 name
= "_gfortran_size";
2059 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2060 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2061 gfc_index_integer_kind
);
2063 ec
= gfc_copy_expr (e
);
2064 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2066 gfc_simplify_expr (fcn
, 0);
2070 /* Builds a logical expression. */
2073 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2078 ts
.type
= BT_LOGICAL
;
2079 ts
.kind
= gfc_default_logical_kind
;
2080 res
= gfc_get_expr ();
2081 res
->where
= e1
->where
;
2082 res
->expr_type
= EXPR_OP
;
2083 res
->value
.op
.op
= op
;
2084 res
->value
.op
.op1
= e1
;
2085 res
->value
.op
.op2
= e2
;
2092 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2093 compatible typespecs. */
2096 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2100 res
= gfc_get_expr ();
2102 res
->where
= e1
->where
;
2103 res
->expr_type
= EXPR_OP
;
2104 res
->value
.op
.op
= op
;
2105 res
->value
.op
.op1
= e1
;
2106 res
->value
.op
.op2
= e2
;
2107 gfc_simplify_expr (res
, 0);
2111 /* Generate the IF statement for a runtime check if we want to do inlining or
2112 not - putting in the code for both branches and putting it into the syntax
2113 tree is the caller's responsibility. For fixed array sizes, this should be
2114 removed by DCE. Only called for rank-two matrices A and B. */
2117 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2119 gfc_expr
*inline_limit
;
2120 gfc_code
*if_1
, *if_2
, *else_2
;
2121 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2125 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2127 /* Calculation is done in real to avoid integer overflow. */
2129 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2131 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2133 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2136 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2137 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2138 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2142 ts
.kind
= gfc_default_real_kind
;
2143 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2144 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2145 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2147 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2148 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2150 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2151 gfc_simplify_expr (cond
, 0);
2153 else_2
= XCNEW (gfc_code
);
2154 else_2
->op
= EXEC_IF
;
2155 else_2
->loc
= a
->where
;
2157 if_2
= XCNEW (gfc_code
);
2160 if_2
->loc
= a
->where
;
2161 if_2
->block
= else_2
;
2163 if_1
= XCNEW (gfc_code
);
2166 if_1
->loc
= a
->where
;
2172 /* Insert code to issue a runtime error if the expressions are not equal. */
2175 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2178 gfc_code
*if_1
, *if_2
;
2180 gfc_actual_arglist
*a1
, *a2
, *a3
;
2182 gcc_assert (e1
->where
.lb
);
2183 /* Build the call to runtime_error. */
2184 c
= XCNEW (gfc_code
);
2188 /* Get a null-terminated message string. */
2190 a1
= gfc_get_actual_arglist ();
2191 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2192 msg
, strlen(msg
)+1);
2195 /* Pass the value of the first expression. */
2196 a2
= gfc_get_actual_arglist ();
2197 a2
->expr
= gfc_copy_expr (e1
);
2200 /* Pass the value of the second expression. */
2201 a3
= gfc_get_actual_arglist ();
2202 a3
->expr
= gfc_copy_expr (e2
);
2205 gfc_check_fe_runtime_error (c
->ext
.actual
);
2206 gfc_resolve_fe_runtime_error (c
);
2208 if_2
= XCNEW (gfc_code
);
2210 if_2
->loc
= e1
->where
;
2213 if_1
= XCNEW (gfc_code
);
2216 if_1
->loc
= e1
->where
;
2218 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2219 gfc_simplify_expr (cond
, 0);
2225 /* Handle matrix reallocation. Caller is responsible to insert into
2228 For the two-dimensional case, build
2230 if (allocated(c)) then
2231 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2233 allocate (c(size(a,1), size(b,2)))
2236 allocate (c(size(a,1),size(b,2)))
2239 and for the other cases correspondingly.
2243 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2244 enum matrix_case m_case
)
2247 gfc_expr
*allocated
, *alloc_expr
;
2248 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2249 gfc_code
*else_alloc
;
2250 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2252 gfc_expr
*cond
, *ne1
, *ne2
;
2254 if (warn_realloc_lhs
)
2255 gfc_warning (OPT_Wrealloc_lhs
,
2256 "Code for reallocating the allocatable array at %L will "
2257 "be added", &c
->where
);
2259 alloc_expr
= gfc_copy_expr (c
);
2261 ar
= gfc_find_array_ref (alloc_expr
);
2262 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2264 /* c comes in as a full ref. Change it into a copy and make it into an
2265 element ref so it has the right form for for ALLOCATE. In the same
2266 switch statement, also generate the size comparison for the secod IF
2269 ar
->type
= AR_ELEMENT
;
2274 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2275 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2276 ne1
= build_logical_expr (INTRINSIC_NE
,
2277 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2278 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2279 ne2
= build_logical_expr (INTRINSIC_NE
,
2280 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2281 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2282 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2286 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2287 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2289 ne1
= build_logical_expr (INTRINSIC_NE
,
2290 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2291 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2292 ne2
= build_logical_expr (INTRINSIC_NE
,
2293 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2294 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2295 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2299 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2300 cond
= build_logical_expr (INTRINSIC_NE
,
2301 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2302 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2306 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2307 cond
= build_logical_expr (INTRINSIC_NE
,
2308 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2309 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2317 gfc_simplify_expr (cond
, 0);
2319 /* We need two identical allocate statements in two
2320 branches of the IF statement. */
2322 allocate1
= XCNEW (gfc_code
);
2323 allocate1
->op
= EXEC_ALLOCATE
;
2324 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2325 allocate1
->loc
= c
->where
;
2326 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2328 allocate_else
= XCNEW (gfc_code
);
2329 allocate_else
->op
= EXEC_ALLOCATE
;
2330 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2331 allocate_else
->loc
= c
->where
;
2332 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2334 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2335 "_gfortran_allocated", c
->where
,
2336 1, gfc_copy_expr (c
));
2338 deallocate
= XCNEW (gfc_code
);
2339 deallocate
->op
= EXEC_DEALLOCATE
;
2340 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2341 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2342 deallocate
->next
= allocate1
;
2343 deallocate
->loc
= c
->where
;
2345 if_size_2
= XCNEW (gfc_code
);
2346 if_size_2
->op
= EXEC_IF
;
2347 if_size_2
->expr1
= cond
;
2348 if_size_2
->loc
= c
->where
;
2349 if_size_2
->next
= deallocate
;
2351 if_size_1
= XCNEW (gfc_code
);
2352 if_size_1
->op
= EXEC_IF
;
2353 if_size_1
->block
= if_size_2
;
2354 if_size_1
->loc
= c
->where
;
2356 else_alloc
= XCNEW (gfc_code
);
2357 else_alloc
->op
= EXEC_IF
;
2358 else_alloc
->loc
= c
->where
;
2359 else_alloc
->next
= allocate_else
;
2361 if_alloc_2
= XCNEW (gfc_code
);
2362 if_alloc_2
->op
= EXEC_IF
;
2363 if_alloc_2
->expr1
= allocated
;
2364 if_alloc_2
->loc
= c
->where
;
2365 if_alloc_2
->next
= if_size_1
;
2366 if_alloc_2
->block
= else_alloc
;
2368 if_alloc_1
= XCNEW (gfc_code
);
2369 if_alloc_1
->op
= EXEC_IF
;
2370 if_alloc_1
->block
= if_alloc_2
;
2371 if_alloc_1
->loc
= c
->where
;
2376 /* Callback function for has_function_or_op. */
2379 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2380 void *data ATTRIBUTE_UNUSED
)
2385 return (*e
)->expr_type
== EXPR_FUNCTION
2386 || (*e
)->expr_type
== EXPR_OP
;
2389 /* Returns true if the expression contains a function. */
2392 has_function_or_op (gfc_expr
**e
)
2397 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2400 /* Freeze (assign to a temporary variable) a single expression. */
2403 freeze_expr (gfc_expr
**ep
)
2406 if (has_function_or_op (ep
))
2408 ne
= create_var (*ep
, "freeze");
2413 /* Go through an expression's references and assign them to temporary
2414 variables if they contain functions. This is usually done prior to
2415 front-end scalarization to avoid multiple invocations of functions. */
2418 freeze_references (gfc_expr
*e
)
2424 for (r
=e
->ref
; r
; r
=r
->next
)
2426 if (r
->type
== REF_SUBSTRING
)
2428 if (r
->u
.ss
.start
!= NULL
)
2429 freeze_expr (&r
->u
.ss
.start
);
2431 if (r
->u
.ss
.end
!= NULL
)
2432 freeze_expr (&r
->u
.ss
.end
);
2434 else if (r
->type
== REF_ARRAY
)
2443 for (i
=0; i
<ar
->dimen
; i
++)
2445 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2447 freeze_expr (&ar
->start
[i
]);
2448 freeze_expr (&ar
->end
[i
]);
2449 freeze_expr (&ar
->stride
[i
]);
2451 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2453 freeze_expr (&ar
->start
[i
]);
2459 for (i
=0; i
<ar
->dimen
; i
++)
2460 freeze_expr (&ar
->start
[i
]);
2470 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2473 convert_to_index_kind (gfc_expr
*e
)
2477 gcc_assert (e
!= NULL
);
2479 res
= gfc_copy_expr (e
);
2481 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2483 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2487 ts
.type
= BT_INTEGER
;
2488 ts
.kind
= gfc_index_integer_kind
;
2490 gfc_convert_type_warn (e
, &ts
, 2, 0);
2496 /* Function to create a DO loop including creation of the
2497 iteration variable. gfc_expr are copied.*/
2500 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2501 gfc_namespace
*ns
, char *vname
)
2504 char name
[GFC_MAX_SYMBOL_LEN
+1];
2505 gfc_symtree
*symtree
;
2510 /* Create an expression for the iteration variable. */
2512 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2514 sprintf (name
, "__var_%d_do", var_num
++);
2517 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2520 /* Create the loop variable. */
2522 symbol
= symtree
->n
.sym
;
2523 symbol
->ts
.type
= BT_INTEGER
;
2524 symbol
->ts
.kind
= gfc_index_integer_kind
;
2525 symbol
->attr
.flavor
= FL_VARIABLE
;
2526 symbol
->attr
.referenced
= 1;
2527 symbol
->attr
.dimension
= 0;
2528 symbol
->attr
.fe_temp
= 1;
2529 gfc_commit_symbol (symbol
);
2531 i
= gfc_get_expr ();
2532 i
->expr_type
= EXPR_VARIABLE
;
2536 i
->symtree
= symtree
;
2538 /* ... and the nested DO statements. */
2539 n
= XCNEW (gfc_code
);
2542 n
->ext
.iterator
= gfc_get_iterator ();
2543 n
->ext
.iterator
->var
= i
;
2544 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2545 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2547 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2549 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2552 n2
= XCNEW (gfc_code
);
2560 /* Get the upper bound of the DO loops for matmul along a dimension. This
2564 get_size_m1 (gfc_expr
*e
, int dimen
)
2569 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2571 res
= gfc_get_constant_expr (BT_INTEGER
,
2572 gfc_index_integer_kind
, &e
->where
);
2573 mpz_sub_ui (res
->value
.integer
, size
, 1);
2578 res
= get_operand (INTRINSIC_MINUS
,
2579 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2580 gfc_get_int_expr (gfc_index_integer_kind
,
2582 gfc_simplify_expr (res
, 0);
2588 /* Function to return a scalarized expression. It is assumed that indices are
2589 zero based to make generation of DO loops easier. A zero as index will
2590 access the first element along a dimension. Single element references will
2591 be skipped. A NULL as an expression will be replaced by a full reference.
2592 This assumes that the index loops have gfc_index_integer_kind, and that all
2593 references have been frozen. */
2596 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2605 e
= gfc_copy_expr(e_in
);
2609 ar
= gfc_find_array_ref (e
);
2611 /* We scalarize count_index variables, reducing the rank by count_index. */
2613 e
->rank
= rank
- count_index
;
2615 was_fullref
= ar
->type
== AR_FULL
;
2618 ar
->type
= AR_ELEMENT
;
2620 ar
->type
= AR_SECTION
;
2622 /* Loop over the indices. For each index, create the expression
2623 index * stride + lbound(e, dim). */
2626 for (i
=0; i
< ar
->dimen
; i
++)
2628 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2630 if (index
[i_index
] != NULL
)
2632 gfc_expr
*lbound
, *nindex
;
2635 loopvar
= gfc_copy_expr (index
[i_index
]);
2641 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2642 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2646 ts
.type
= BT_INTEGER
;
2647 ts
.kind
= gfc_index_integer_kind
;
2648 gfc_convert_type (tmp
, &ts
, 2);
2650 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2655 /* Calculate the lower bound of the expression. */
2658 lbound
= gfc_copy_expr (ar
->start
[i
]);
2659 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2663 ts
.type
= BT_INTEGER
;
2664 ts
.kind
= gfc_index_integer_kind
;
2665 gfc_convert_type (lbound
, &ts
, 2);
2674 lbound_e
= gfc_copy_expr (e_in
);
2676 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2677 if (ref
->type
== REF_ARRAY
2678 && (ref
->u
.ar
.type
== AR_FULL
2679 || ref
->u
.ar
.type
== AR_SECTION
))
2684 gfc_free_ref_list (ref
->next
);
2690 /* Look at full individual sections, like a(:). The first index
2691 is the lbound of a full ref. */
2697 for (j
= 0; j
< ar
->dimen
; j
++)
2699 gfc_free_expr (ar
->start
[j
]);
2700 ar
->start
[j
] = NULL
;
2701 gfc_free_expr (ar
->end
[j
]);
2703 gfc_free_expr (ar
->stride
[j
]);
2704 ar
->stride
[j
] = NULL
;
2707 /* We have to get rid of the shape, if there is one. Do
2708 so by freeing it and calling gfc_resolve to rebuild
2709 it, if necessary. */
2711 if (lbound_e
->shape
)
2712 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2714 lbound_e
->rank
= ar
->dimen
;
2715 gfc_resolve_expr (lbound_e
);
2717 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2719 gfc_free_expr (lbound_e
);
2722 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2724 gfc_free_expr (ar
->start
[i
]);
2725 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2727 gfc_free_expr (ar
->end
[i
]);
2729 gfc_free_expr (ar
->stride
[i
]);
2730 ar
->stride
[i
] = NULL
;
2731 gfc_simplify_expr (ar
->start
[i
], 0);
2733 else if (was_fullref
)
2735 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2744 /* Helper function to check for a dimen vector as subscript. */
2747 has_dimen_vector_ref (gfc_expr
*e
)
2752 ar
= gfc_find_array_ref (e
);
2754 if (ar
->type
== AR_FULL
)
2757 for (i
=0; i
<ar
->dimen
; i
++)
2758 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2764 /* If handed an expression of the form
2768 check if A can be handled by matmul and return if there is an uneven number
2769 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2770 otherwise. The caller has to check for the correct rank. */
2773 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2780 if (e
->expr_type
== EXPR_VARIABLE
)
2782 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2785 else if (e
->expr_type
== EXPR_FUNCTION
)
2787 if (e
->value
.function
.isym
== NULL
)
2790 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2792 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2793 *transpose
= !*transpose
;
2799 e
= e
->value
.function
.actual
->expr
;
2806 /* Inline assignments of the form c = matmul(a,b).
2807 Handle only the cases currently where b and c are rank-two arrays.
2809 This basically translates the code to
2815 do k=0, size(a, 2)-1
2816 do i=0, size(a, 1)-1
2817 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2818 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2819 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2820 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2829 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2830 void *data ATTRIBUTE_UNUSED
)
2833 gfc_expr
*expr1
, *expr2
;
2834 gfc_expr
*matrix_a
, *matrix_b
;
2835 gfc_actual_arglist
*a
, *b
;
2836 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2838 gfc_expr
*u1
, *u2
, *u3
;
2840 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2842 gfc_expr
*var_1
, *var_2
, *var_3
;
2845 gfc_intrinsic_op op_times
, op_plus
;
2846 enum matrix_case m_case
;
2848 gfc_code
*if_limit
= NULL
;
2849 gfc_code
**next_code_point
;
2850 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2852 if (co
->op
!= EXEC_ASSIGN
)
2858 /* For now don't do anything in OpenMP workshare, it confuses
2859 its translation, which expects only the allowed statements in there.
2860 We should figure out how to parallelize this eventually. */
2861 if (in_omp_workshare
)
2866 if (expr2
->expr_type
!= EXPR_FUNCTION
2867 || expr2
->value
.function
.isym
== NULL
2868 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2872 inserted_block
= NULL
;
2873 changed_statement
= NULL
;
2875 a
= expr2
->value
.function
.actual
;
2876 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2877 if (transpose_a
|| matrix_a
== NULL
)
2881 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2882 if (matrix_b
== NULL
)
2885 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2886 || has_dimen_vector_ref (matrix_b
))
2889 /* We do not handle data dependencies yet. */
2890 if (gfc_check_dependency (expr1
, matrix_a
, true)
2891 || gfc_check_dependency (expr1
, matrix_b
, true))
2894 if (matrix_a
->rank
== 2)
2896 if (matrix_b
->rank
== 1)
2908 /* Vector * Transpose(B) not handled yet. */
2918 ns
= insert_block ();
2920 /* Assign the type of the zero expression for initializing the resulting
2921 array, and the expression (+ and * for real, integer and complex;
2922 .and. and .or for logical. */
2924 switch(expr1
->ts
.type
)
2927 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2928 op_times
= INTRINSIC_TIMES
;
2929 op_plus
= INTRINSIC_PLUS
;
2933 op_times
= INTRINSIC_AND
;
2934 op_plus
= INTRINSIC_OR
;
2935 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2939 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2941 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2942 op_times
= INTRINSIC_TIMES
;
2943 op_plus
= INTRINSIC_PLUS
;
2947 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2949 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2950 op_times
= INTRINSIC_TIMES
;
2951 op_plus
= INTRINSIC_PLUS
;
2959 current_code
= &ns
->code
;
2961 /* Freeze the references, keeping track of how many temporary variables were
2964 freeze_references (matrix_a
);
2965 freeze_references (matrix_b
);
2966 freeze_references (expr1
);
2969 next_code_point
= current_code
;
2972 next_code_point
= &ns
->code
;
2973 for (i
=0; i
<n_vars
; i
++)
2974 next_code_point
= &(*next_code_point
)->next
;
2977 /* Take care of the inline flag. If the limit check evaluates to a
2978 constant, dead code elimination will eliminate the unneeded branch. */
2980 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2982 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2984 /* Insert the original statement into the else branch. */
2985 if_limit
->block
->block
->next
= co
;
2988 /* ... and the new ones go into the original one. */
2989 *next_code_point
= if_limit
;
2990 next_code_point
= &if_limit
->block
->next
;
2993 assign_zero
= XCNEW (gfc_code
);
2994 assign_zero
->op
= EXEC_ASSIGN
;
2995 assign_zero
->loc
= co
->loc
;
2996 assign_zero
->expr1
= gfc_copy_expr (expr1
);
2997 assign_zero
->expr2
= zero_e
;
2999 /* Handle the reallocation, if needed. */
3000 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3002 gfc_code
*lhs_alloc
;
3004 /* Only need to check a single dimension for the A2B2 case for
3005 bounds checking, the rest will be allocated. */
3007 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
3012 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3013 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3014 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3015 "in MATMUL intrinsic: Is %ld, should be %ld");
3016 *next_code_point
= test
;
3017 next_code_point
= &test
->next
;
3021 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3023 *next_code_point
= lhs_alloc
;
3024 next_code_point
= &lhs_alloc
->next
;
3027 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3030 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3032 if (m_case
== A2B2
|| m_case
== A2B1
)
3034 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3035 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3036 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3037 "in MATMUL intrinsic: Is %ld, should be %ld");
3038 *next_code_point
= test
;
3039 next_code_point
= &test
->next
;
3041 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3042 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3045 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3046 "MATMUL intrinsic for dimension 1: "
3047 "is %ld, should be %ld");
3048 else if (m_case
== A2B1
)
3049 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3050 "MATMUL intrinsic: "
3051 "is %ld, should be %ld");
3054 *next_code_point
= test
;
3055 next_code_point
= &test
->next
;
3057 else if (m_case
== A1B2
)
3059 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3060 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3061 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3062 "in MATMUL intrinsic: Is %ld, should be %ld");
3063 *next_code_point
= test
;
3064 next_code_point
= &test
->next
;
3066 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3067 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3069 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3070 "MATMUL intrinsic: "
3071 "is %ld, should be %ld");
3073 *next_code_point
= test
;
3074 next_code_point
= &test
->next
;
3079 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3080 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3081 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3082 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3084 *next_code_point
= test
;
3085 next_code_point
= &test
->next
;
3088 if (m_case
== A2B2T
)
3090 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3091 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3092 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3093 "MATMUL intrinsic for dimension 1: "
3094 "is %ld, should be %ld");
3096 *next_code_point
= test
;
3097 next_code_point
= &test
->next
;
3099 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3100 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3101 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3102 "MATMUL intrinsic for dimension 2: "
3103 "is %ld, should be %ld");
3104 *next_code_point
= test
;
3105 next_code_point
= &test
->next
;
3107 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3108 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3110 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3111 "MATMUL intrnisic for dimension 2: "
3112 "is %ld, should be %ld");
3113 *next_code_point
= test
;
3114 next_code_point
= &test
->next
;
3119 *next_code_point
= assign_zero
;
3121 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3123 assign_matmul
= XCNEW (gfc_code
);
3124 assign_matmul
->op
= EXEC_ASSIGN
;
3125 assign_matmul
->loc
= co
->loc
;
3127 /* Get the bounds for the loops, create them and create the scalarized
3133 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3135 u1
= get_size_m1 (matrix_b
, 2);
3136 u2
= get_size_m1 (matrix_a
, 2);
3137 u3
= get_size_m1 (matrix_a
, 1);
3139 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3140 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3141 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3143 do_1
->block
->next
= do_2
;
3144 do_2
->block
->next
= do_3
;
3145 do_3
->block
->next
= assign_matmul
;
3147 var_1
= do_1
->ext
.iterator
->var
;
3148 var_2
= do_2
->ext
.iterator
->var
;
3149 var_3
= do_3
->ext
.iterator
->var
;
3153 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3157 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3161 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3166 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3168 u1
= get_size_m1 (matrix_b
, 1);
3169 u2
= get_size_m1 (matrix_a
, 2);
3170 u3
= get_size_m1 (matrix_a
, 1);
3172 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3173 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3174 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3176 do_1
->block
->next
= do_2
;
3177 do_2
->block
->next
= do_3
;
3178 do_3
->block
->next
= assign_matmul
;
3180 var_1
= do_1
->ext
.iterator
->var
;
3181 var_2
= do_2
->ext
.iterator
->var
;
3182 var_3
= do_3
->ext
.iterator
->var
;
3186 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3190 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3194 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3199 u1
= get_size_m1 (matrix_b
, 1);
3200 u2
= get_size_m1 (matrix_a
, 1);
3202 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3203 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3205 do_1
->block
->next
= do_2
;
3206 do_2
->block
->next
= assign_matmul
;
3208 var_1
= do_1
->ext
.iterator
->var
;
3209 var_2
= do_2
->ext
.iterator
->var
;
3212 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3216 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3219 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3224 u1
= get_size_m1 (matrix_b
, 2);
3225 u2
= get_size_m1 (matrix_a
, 1);
3227 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3228 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3230 do_1
->block
->next
= do_2
;
3231 do_2
->block
->next
= assign_matmul
;
3233 var_1
= do_1
->ext
.iterator
->var
;
3234 var_2
= do_2
->ext
.iterator
->var
;
3237 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3240 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3244 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3253 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3254 matrix_a
->where
, 1, ascalar
);
3257 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3258 matrix_b
->where
, 1, bscalar
);
3260 /* First loop comes after the zero assignment. */
3261 assign_zero
->next
= do_1
;
3263 /* Build the assignment expression in the loop. */
3264 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3266 mult
= get_operand (op_times
, ascalar
, bscalar
);
3267 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3269 /* If we don't want to keep the original statement around in
3270 the else branch, we can free it. */
3272 if (if_limit
== NULL
)
3273 gfc_free_statements(co
);
3277 gfc_free_expr (zero
);
3282 #define WALK_SUBEXPR(NODE) \
3285 result = gfc_expr_walker (&(NODE), exprfn, data); \
3290 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3292 /* Walk expression *E, calling EXPRFN on each expression in it. */
3295 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3299 int walk_subtrees
= 1;
3300 gfc_actual_arglist
*a
;
3304 int result
= exprfn (e
, &walk_subtrees
, data
);
3308 switch ((*e
)->expr_type
)
3311 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3312 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3315 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3316 WALK_SUBEXPR (a
->expr
);
3320 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3321 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3322 WALK_SUBEXPR (a
->expr
);
3325 case EXPR_STRUCTURE
:
3327 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3328 c
= gfc_constructor_next (c
))
3330 if (c
->iterator
== NULL
)
3331 WALK_SUBEXPR (c
->expr
);
3335 WALK_SUBEXPR (c
->expr
);
3337 WALK_SUBEXPR (c
->iterator
->var
);
3338 WALK_SUBEXPR (c
->iterator
->start
);
3339 WALK_SUBEXPR (c
->iterator
->end
);
3340 WALK_SUBEXPR (c
->iterator
->step
);
3344 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3347 /* Fall through to the variable case in order to walk the
3350 case EXPR_SUBSTRING
:
3352 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3361 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3363 for (i
=0; i
< ar
->dimen
; i
++)
3365 WALK_SUBEXPR (ar
->start
[i
]);
3366 WALK_SUBEXPR (ar
->end
[i
]);
3367 WALK_SUBEXPR (ar
->stride
[i
]);
3374 WALK_SUBEXPR (r
->u
.ss
.start
);
3375 WALK_SUBEXPR (r
->u
.ss
.end
);
3391 #define WALK_SUBCODE(NODE) \
3394 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3400 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3401 on each expression in it. If any of the hooks returns non-zero, that
3402 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3403 no subcodes or subexpressions are traversed. */
3406 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3409 for (; *c
; c
= &(*c
)->next
)
3411 int walk_subtrees
= 1;
3412 int result
= codefn (c
, &walk_subtrees
, data
);
3419 gfc_actual_arglist
*a
;
3421 gfc_association_list
*alist
;
3422 bool saved_in_omp_workshare
;
3423 bool saved_in_where
;
3425 /* There might be statement insertions before the current code,
3426 which must not affect the expression walker. */
3429 saved_in_omp_workshare
= in_omp_workshare
;
3430 saved_in_where
= in_where
;
3436 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3437 if (co
->ext
.block
.assoc
)
3439 bool saved_in_assoc_list
= in_assoc_list
;
3441 in_assoc_list
= true;
3442 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3443 WALK_SUBEXPR (alist
->target
);
3445 in_assoc_list
= saved_in_assoc_list
;
3452 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3453 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3454 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3455 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3463 case EXEC_ASSIGN_CALL
:
3464 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3465 WALK_SUBEXPR (a
->expr
);
3469 WALK_SUBEXPR (co
->expr1
);
3470 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3471 WALK_SUBEXPR (a
->expr
);
3475 WALK_SUBEXPR (co
->expr1
);
3476 for (b
= co
->block
; b
; b
= b
->block
)
3479 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3481 WALK_SUBEXPR (cp
->low
);
3482 WALK_SUBEXPR (cp
->high
);
3484 WALK_SUBCODE (b
->next
);
3489 case EXEC_DEALLOCATE
:
3492 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3493 WALK_SUBEXPR (a
->expr
);
3498 case EXEC_DO_CONCURRENT
:
3500 gfc_forall_iterator
*fa
;
3501 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3503 WALK_SUBEXPR (fa
->var
);
3504 WALK_SUBEXPR (fa
->start
);
3505 WALK_SUBEXPR (fa
->end
);
3506 WALK_SUBEXPR (fa
->stride
);
3508 if (co
->op
== EXEC_FORALL
)
3514 WALK_SUBEXPR (co
->ext
.open
->unit
);
3515 WALK_SUBEXPR (co
->ext
.open
->file
);
3516 WALK_SUBEXPR (co
->ext
.open
->status
);
3517 WALK_SUBEXPR (co
->ext
.open
->access
);
3518 WALK_SUBEXPR (co
->ext
.open
->form
);
3519 WALK_SUBEXPR (co
->ext
.open
->recl
);
3520 WALK_SUBEXPR (co
->ext
.open
->blank
);
3521 WALK_SUBEXPR (co
->ext
.open
->position
);
3522 WALK_SUBEXPR (co
->ext
.open
->action
);
3523 WALK_SUBEXPR (co
->ext
.open
->delim
);
3524 WALK_SUBEXPR (co
->ext
.open
->pad
);
3525 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3526 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3527 WALK_SUBEXPR (co
->ext
.open
->convert
);
3528 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3529 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3530 WALK_SUBEXPR (co
->ext
.open
->round
);
3531 WALK_SUBEXPR (co
->ext
.open
->sign
);
3532 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3533 WALK_SUBEXPR (co
->ext
.open
->id
);
3534 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3538 WALK_SUBEXPR (co
->ext
.close
->unit
);
3539 WALK_SUBEXPR (co
->ext
.close
->status
);
3540 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3541 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3544 case EXEC_BACKSPACE
:
3548 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3549 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3550 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3554 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3555 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3556 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3557 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3558 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3559 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3560 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3561 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3562 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3563 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3564 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3565 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3566 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3567 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3568 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3569 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3570 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3571 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3572 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3573 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3574 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3575 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3576 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3577 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3578 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3579 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3580 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3581 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3582 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3583 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3584 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3585 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3586 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3587 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3588 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3589 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3593 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3594 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3595 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3596 WALK_SUBEXPR (co
->ext
.wait
->id
);
3601 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3602 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3603 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3604 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3605 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3606 WALK_SUBEXPR (co
->ext
.dt
->size
);
3607 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3608 WALK_SUBEXPR (co
->ext
.dt
->id
);
3609 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3610 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3611 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3612 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3613 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3614 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3615 WALK_SUBEXPR (co
->ext
.dt
->round
);
3616 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3617 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3620 case EXEC_OMP_PARALLEL
:
3621 case EXEC_OMP_PARALLEL_DO
:
3622 case EXEC_OMP_PARALLEL_DO_SIMD
:
3623 case EXEC_OMP_PARALLEL_SECTIONS
:
3625 in_omp_workshare
= false;
3627 /* This goto serves as a shortcut to avoid code
3628 duplication or a larger if or switch statement. */
3629 goto check_omp_clauses
;
3631 case EXEC_OMP_WORKSHARE
:
3632 case EXEC_OMP_PARALLEL_WORKSHARE
:
3634 in_omp_workshare
= true;
3638 case EXEC_OMP_DISTRIBUTE
:
3639 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3640 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3641 case EXEC_OMP_DISTRIBUTE_SIMD
:
3643 case EXEC_OMP_DO_SIMD
:
3644 case EXEC_OMP_SECTIONS
:
3645 case EXEC_OMP_SINGLE
:
3646 case EXEC_OMP_END_SINGLE
:
3648 case EXEC_OMP_TARGET
:
3649 case EXEC_OMP_TARGET_DATA
:
3650 case EXEC_OMP_TARGET_TEAMS
:
3651 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3652 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3653 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3654 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3655 case EXEC_OMP_TARGET_UPDATE
:
3657 case EXEC_OMP_TEAMS
:
3658 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3659 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3660 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3661 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3663 /* Come to this label only from the
3664 EXEC_OMP_PARALLEL_* cases above. */
3668 if (co
->ext
.omp_clauses
)
3670 gfc_omp_namelist
*n
;
3671 static int list_types
[]
3672 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3673 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3675 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3676 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3677 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3678 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3679 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3680 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3681 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3682 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3683 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3684 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3686 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3688 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3690 WALK_SUBEXPR (n
->expr
);
3697 WALK_SUBEXPR (co
->expr1
);
3698 WALK_SUBEXPR (co
->expr2
);
3699 WALK_SUBEXPR (co
->expr3
);
3700 WALK_SUBEXPR (co
->expr4
);
3701 for (b
= co
->block
; b
; b
= b
->block
)
3703 WALK_SUBEXPR (b
->expr1
);
3704 WALK_SUBEXPR (b
->expr2
);
3705 WALK_SUBCODE (b
->next
);
3708 if (co
->op
== EXEC_FORALL
)
3711 if (co
->op
== EXEC_DO
)
3714 in_omp_workshare
= saved_in_omp_workshare
;
3715 in_where
= saved_in_where
;