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
)
1083 if (e
->expr_type
== EXPR_OP
)
1085 switch (e
->value
.op
.op
)
1087 /* Unary operators and exponentiation: Only look at a single
1090 case INTRINSIC_UPLUS
:
1091 case INTRINSIC_UMINUS
:
1092 case INTRINSIC_PARENTHESES
:
1093 case INTRINSIC_POWER
:
1094 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1098 case INTRINSIC_CONCAT
:
1099 /* Do not do string concatenations. */
1103 /* Binary operators. */
1104 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1107 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1113 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1114 && ! (e
->value
.function
.esym
1115 && (e
->value
.function
.esym
->attr
.elemental
1116 || e
->value
.function
.esym
->attr
.allocatable
1117 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1118 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1119 && ! (e
->value
.function
.isym
1120 && (e
->value
.function
.isym
->elemental
1121 || e
->ts
.type
!= c
->expr1
->ts
.type
1122 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1123 && ! gfc_inline_intrinsic_function_p (e
))
1129 /* Insert a new assignment statement after the current one. */
1130 n
= XCNEW (gfc_code
);
1131 n
->op
= EXEC_ASSIGN
;
1136 n
->expr1
= gfc_copy_expr (c
->expr1
);
1137 n
->expr2
= c
->expr2
;
1138 new_expr
= gfc_copy_expr (c
->expr1
);
1146 /* Nothing to optimize. */
1150 /* Remove unneeded TRIMs at the end of expressions. */
1153 remove_trim (gfc_expr
*rhs
)
1161 /* Check for a // b // trim(c). Looping is probably not
1162 necessary because the parser usually generates
1163 (// (// a b ) trim(c) ) , but better safe than sorry. */
1165 while (rhs
->expr_type
== EXPR_OP
1166 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1167 rhs
= rhs
->value
.op
.op2
;
1169 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1170 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1172 strip_function_call (rhs
);
1173 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1181 /* Optimizations for an assignment. */
1184 optimize_assignment (gfc_code
* c
)
1186 gfc_expr
*lhs
, *rhs
;
1191 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1193 /* Optimize a = trim(b) to a = b. */
1196 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1197 if (is_empty_string (rhs
))
1198 rhs
->value
.character
.length
= 0;
1201 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1202 optimize_binop_array_assignment (c
, &rhs
, false);
1206 /* Remove an unneeded function call, modifying the expression.
1207 This replaces the function call with the value of its
1208 first argument. The rest of the argument list is freed. */
1211 strip_function_call (gfc_expr
*e
)
1214 gfc_actual_arglist
*a
;
1216 a
= e
->value
.function
.actual
;
1218 /* We should have at least one argument. */
1219 gcc_assert (a
->expr
!= NULL
);
1223 /* Free the remaining arglist, if any. */
1225 gfc_free_actual_arglist (a
->next
);
1227 /* Graft the argument expression onto the original function. */
1233 /* Optimization of lexical comparison functions. */
1236 optimize_lexical_comparison (gfc_expr
*e
)
1238 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1241 switch (e
->value
.function
.isym
->id
)
1244 return optimize_comparison (e
, INTRINSIC_LE
);
1247 return optimize_comparison (e
, INTRINSIC_GE
);
1250 return optimize_comparison (e
, INTRINSIC_GT
);
1253 return optimize_comparison (e
, INTRINSIC_LT
);
1261 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1262 do CHARACTER because of possible pessimization involving character
1266 combine_array_constructor (gfc_expr
*e
)
1269 gfc_expr
*op1
, *op2
;
1272 gfc_constructor
*c
, *new_c
;
1273 gfc_constructor_base oldbase
, newbase
;
1276 /* Array constructors have rank one. */
1280 /* Don't try to combine association lists, this makes no sense
1281 and leads to an ICE. */
1285 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1286 if (forall_level
> 0)
1289 /* Inside an iterator, things can get hairy; we are likely to create
1290 an invalid temporary variable. */
1291 if (iterator_level
> 0)
1294 op1
= e
->value
.op
.op1
;
1295 op2
= e
->value
.op
.op2
;
1300 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1301 scalar_first
= false;
1302 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1304 scalar_first
= true;
1305 op1
= e
->value
.op
.op2
;
1306 op2
= e
->value
.op
.op1
;
1311 if (op2
->ts
.type
== BT_CHARACTER
)
1314 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1316 oldbase
= op1
->value
.constructor
;
1318 e
->expr_type
= EXPR_ARRAY
;
1320 for (c
= gfc_constructor_first (oldbase
); c
;
1321 c
= gfc_constructor_next (c
))
1323 new_expr
= gfc_get_expr ();
1324 new_expr
->ts
= e
->ts
;
1325 new_expr
->expr_type
= EXPR_OP
;
1326 new_expr
->rank
= c
->expr
->rank
;
1327 new_expr
->where
= c
->where
;
1328 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1332 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1333 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1337 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1338 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1341 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1342 new_c
->iterator
= c
->iterator
;
1346 gfc_free_expr (op1
);
1347 gfc_free_expr (op2
);
1348 gfc_free_expr (scalar
);
1350 e
->value
.constructor
= newbase
;
1354 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1355 2**k into ishift(1,k) */
1358 optimize_power (gfc_expr
*e
)
1360 gfc_expr
*op1
, *op2
;
1361 gfc_expr
*iand
, *ishft
;
1363 if (e
->ts
.type
!= BT_INTEGER
)
1366 op1
= e
->value
.op
.op1
;
1368 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1371 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1373 gfc_free_expr (op1
);
1375 op2
= e
->value
.op
.op2
;
1380 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1381 "_internal_iand", e
->where
, 2, op2
,
1382 gfc_get_int_expr (e
->ts
.kind
,
1385 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1386 "_internal_ishft", e
->where
, 2, iand
,
1387 gfc_get_int_expr (e
->ts
.kind
,
1390 e
->value
.op
.op
= INTRINSIC_MINUS
;
1391 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1392 e
->value
.op
.op2
= ishft
;
1395 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1397 gfc_free_expr (op1
);
1399 op2
= e
->value
.op
.op2
;
1403 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1404 "_internal_ishft", e
->where
, 2,
1405 gfc_get_int_expr (e
->ts
.kind
,
1412 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1414 op2
= e
->value
.op
.op2
;
1418 gfc_free_expr (op1
);
1419 gfc_free_expr (op2
);
1421 e
->expr_type
= EXPR_CONSTANT
;
1422 e
->value
.op
.op1
= NULL
;
1423 e
->value
.op
.op2
= NULL
;
1424 mpz_init_set_si (e
->value
.integer
, 1);
1425 /* Typespec and location are still OK. */
1432 /* Recursive optimization of operators. */
1435 optimize_op (gfc_expr
*e
)
1439 gfc_intrinsic_op op
= e
->value
.op
.op
;
1443 /* Only use new-style comparisons. */
1446 case INTRINSIC_EQ_OS
:
1450 case INTRINSIC_GE_OS
:
1454 case INTRINSIC_LE_OS
:
1458 case INTRINSIC_NE_OS
:
1462 case INTRINSIC_GT_OS
:
1466 case INTRINSIC_LT_OS
:
1482 changed
= optimize_comparison (e
, op
);
1485 /* Look at array constructors. */
1486 case INTRINSIC_PLUS
:
1487 case INTRINSIC_MINUS
:
1488 case INTRINSIC_TIMES
:
1489 case INTRINSIC_DIVIDE
:
1490 return combine_array_constructor (e
) || changed
;
1492 case INTRINSIC_POWER
:
1493 return optimize_power (e
);
1503 /* Return true if a constant string contains only blanks. */
1506 is_empty_string (gfc_expr
*e
)
1510 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1513 for (i
=0; i
< e
->value
.character
.length
; i
++)
1515 if (e
->value
.character
.string
[i
] != ' ')
1523 /* Insert a call to the intrinsic len_trim. Use a different name for
1524 the symbol tree so we don't run into trouble when the user has
1525 renamed len_trim for some reason. */
1528 get_len_trim_call (gfc_expr
*str
, int kind
)
1531 gfc_actual_arglist
*actual_arglist
, *next
;
1533 fcn
= gfc_get_expr ();
1534 fcn
->expr_type
= EXPR_FUNCTION
;
1535 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1536 actual_arglist
= gfc_get_actual_arglist ();
1537 actual_arglist
->expr
= str
;
1538 next
= gfc_get_actual_arglist ();
1539 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1540 actual_arglist
->next
= next
;
1542 fcn
->value
.function
.actual
= actual_arglist
;
1543 fcn
->where
= str
->where
;
1544 fcn
->ts
.type
= BT_INTEGER
;
1545 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1547 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1548 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1549 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1550 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1551 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1552 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1553 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1554 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1559 /* Optimize expressions for equality. */
1562 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1564 gfc_expr
*op1
, *op2
;
1568 gfc_actual_arglist
*firstarg
, *secondarg
;
1570 if (e
->expr_type
== EXPR_OP
)
1574 op1
= e
->value
.op
.op1
;
1575 op2
= e
->value
.op
.op2
;
1577 else if (e
->expr_type
== EXPR_FUNCTION
)
1579 /* One of the lexical comparison functions. */
1580 firstarg
= e
->value
.function
.actual
;
1581 secondarg
= firstarg
->next
;
1582 op1
= firstarg
->expr
;
1583 op2
= secondarg
->expr
;
1588 /* Strip off unneeded TRIM calls from string comparisons. */
1590 change
= remove_trim (op1
);
1592 if (remove_trim (op2
))
1595 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1596 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1597 handles them well). However, there are also cases that need a non-scalar
1598 argument. For example the any intrinsic. See PR 45380. */
1602 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1604 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1605 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1607 bool empty_op1
, empty_op2
;
1608 empty_op1
= is_empty_string (op1
);
1609 empty_op2
= is_empty_string (op2
);
1611 if (empty_op1
|| empty_op2
)
1617 /* This can only happen when an error for comparing
1618 characters of different kinds has already been issued. */
1619 if (empty_op1
&& empty_op2
)
1622 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1623 str
= empty_op1
? op2
: op1
;
1625 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1629 gfc_free_expr (op1
);
1631 gfc_free_expr (op2
);
1635 e
->value
.op
.op1
= fcn
;
1636 e
->value
.op
.op2
= zero
;
1641 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1643 if (flag_finite_math_only
1644 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1645 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1647 eq
= gfc_dep_compare_expr (op1
, op2
);
1650 /* Replace A // B < A // C with B < C, and A // B < C // B
1652 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1653 && op1
->expr_type
== EXPR_OP
1654 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1655 && op2
->expr_type
== EXPR_OP
1656 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1658 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1659 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1660 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1661 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1663 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1665 /* Watch out for 'A ' // x vs. 'A' // x. */
1667 if (op1_left
->expr_type
== EXPR_CONSTANT
1668 && op2_left
->expr_type
== EXPR_CONSTANT
1669 && op1_left
->value
.character
.length
1670 != op2_left
->value
.character
.length
)
1678 firstarg
->expr
= op1_right
;
1679 secondarg
->expr
= op2_right
;
1683 e
->value
.op
.op1
= op1_right
;
1684 e
->value
.op
.op2
= op2_right
;
1686 optimize_comparison (e
, op
);
1690 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1696 firstarg
->expr
= op1_left
;
1697 secondarg
->expr
= op2_left
;
1701 e
->value
.op
.op1
= op1_left
;
1702 e
->value
.op
.op2
= op2_left
;
1705 optimize_comparison (e
, op
);
1712 /* eq can only be -1, 0 or 1 at this point. */
1740 gfc_internal_error ("illegal OP in optimize_comparison");
1744 /* Replace the expression by a constant expression. The typespec
1745 and where remains the way it is. */
1748 e
->expr_type
= EXPR_CONSTANT
;
1749 e
->value
.logical
= result
;
1757 /* Optimize a trim function by replacing it with an equivalent substring
1758 involving a call to len_trim. This only works for expressions where
1759 variables are trimmed. Return true if anything was modified. */
1762 optimize_trim (gfc_expr
*e
)
1767 gfc_ref
**rr
= NULL
;
1769 /* Don't do this optimization within an argument list, because
1770 otherwise aliasing issues may occur. */
1772 if (count_arglist
!= 1)
1775 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1776 || e
->value
.function
.isym
== NULL
1777 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1780 a
= e
->value
.function
.actual
->expr
;
1782 if (a
->expr_type
!= EXPR_VARIABLE
)
1785 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1787 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1790 /* Follow all references to find the correct place to put the newly
1791 created reference. FIXME: Also handle substring references and
1792 array references. Array references cause strange regressions at
1797 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1799 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1804 strip_function_call (e
);
1809 /* Create the reference. */
1811 ref
= gfc_get_ref ();
1812 ref
->type
= REF_SUBSTRING
;
1814 /* Set the start of the reference. */
1816 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1818 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1820 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1822 /* Set the end of the reference to the call to len_trim. */
1824 ref
->u
.ss
.end
= fcn
;
1825 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1830 /* Optimize minloc(b), where b is rank 1 array, into
1831 (/ minloc(b, dim=1) /), and similarly for maxloc,
1832 as the latter forms are expanded inline. */
1835 optimize_minmaxloc (gfc_expr
**e
)
1838 gfc_actual_arglist
*a
;
1842 || fn
->value
.function
.actual
== NULL
1843 || fn
->value
.function
.actual
->expr
== NULL
1844 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1847 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1848 (*e
)->shape
= fn
->shape
;
1851 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1853 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1854 strcpy (name
, fn
->value
.function
.name
);
1855 p
= strstr (name
, "loc0");
1857 fn
->value
.function
.name
= gfc_get_string (name
);
1858 if (fn
->value
.function
.actual
->next
)
1860 a
= fn
->value
.function
.actual
->next
;
1861 gcc_assert (a
->expr
== NULL
);
1865 a
= gfc_get_actual_arglist ();
1866 fn
->value
.function
.actual
->next
= a
;
1868 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1870 mpz_set_ui (a
->expr
->value
.integer
, 1);
1873 /* Callback function for code checking that we do not pass a DO variable to an
1874 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1877 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1878 void *data ATTRIBUTE_UNUSED
)
1882 gfc_formal_arglist
*f
;
1883 gfc_actual_arglist
*a
;
1888 /* If the doloop_list grew, we have to truncate it here. */
1890 if ((unsigned) doloop_level
< doloop_list
.length())
1891 doloop_list
.truncate (doloop_level
);
1897 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1898 doloop_list
.safe_push (co
);
1900 doloop_list
.safe_push ((gfc_code
*) NULL
);
1905 if (co
->resolved_sym
== NULL
)
1908 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1910 /* Withot a formal arglist, there is only unknown INTENT,
1911 which we don't check for. */
1919 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1926 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1928 if (a
->expr
&& a
->expr
->symtree
1929 && a
->expr
->symtree
->n
.sym
== do_sym
)
1931 if (f
->sym
->attr
.intent
== INTENT_OUT
)
1932 gfc_error_now ("Variable %qs at %L set to undefined "
1933 "value inside loop beginning at %L as "
1934 "INTENT(OUT) argument to subroutine %qs",
1935 do_sym
->name
, &a
->expr
->where
,
1936 &doloop_list
[i
]->loc
,
1937 co
->symtree
->n
.sym
->name
);
1938 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
1939 gfc_error_now ("Variable %qs at %L not definable inside "
1940 "loop beginning at %L as INTENT(INOUT) "
1941 "argument to subroutine %qs",
1942 do_sym
->name
, &a
->expr
->where
,
1943 &doloop_list
[i
]->loc
,
1944 co
->symtree
->n
.sym
->name
);
1958 /* Callback function for functions checking that we do not pass a DO variable
1959 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
1962 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1963 void *data ATTRIBUTE_UNUSED
)
1965 gfc_formal_arglist
*f
;
1966 gfc_actual_arglist
*a
;
1972 if (expr
->expr_type
!= EXPR_FUNCTION
)
1975 /* Intrinsic functions don't modify their arguments. */
1977 if (expr
->value
.function
.isym
)
1980 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
1982 /* Without a formal arglist, there is only unknown INTENT,
1983 which we don't check for. */
1987 a
= expr
->value
.function
.actual
;
1991 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
1998 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2000 if (a
->expr
&& a
->expr
->symtree
2001 && a
->expr
->symtree
->n
.sym
== do_sym
)
2003 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2004 gfc_error_now ("Variable %qs at %L set to undefined value "
2005 "inside loop beginning at %L as INTENT(OUT) "
2006 "argument to function %qs", do_sym
->name
,
2007 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2008 expr
->symtree
->n
.sym
->name
);
2009 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2010 gfc_error_now ("Variable %qs at %L not definable inside loop"
2011 " beginning at %L as INTENT(INOUT) argument to"
2012 " function %qs", do_sym
->name
,
2013 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2014 expr
->symtree
->n
.sym
->name
);
2025 doloop_warn (gfc_namespace
*ns
)
2027 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2030 /* This selction deals with inlining calls to MATMUL. */
2032 /* Auxiliary function to build and simplify an array inquiry function.
2033 dim is zero-based. */
2036 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2039 gfc_expr
*dim_arg
, *kind
;
2045 case GFC_ISYM_LBOUND
:
2046 name
= "_gfortran_lbound";
2049 case GFC_ISYM_UBOUND
:
2050 name
= "_gfortran_ubound";
2054 name
= "_gfortran_size";
2061 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2062 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2063 gfc_index_integer_kind
);
2065 ec
= gfc_copy_expr (e
);
2066 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2068 gfc_simplify_expr (fcn
, 0);
2072 /* Builds a logical expression. */
2075 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2080 ts
.type
= BT_LOGICAL
;
2081 ts
.kind
= gfc_default_logical_kind
;
2082 res
= gfc_get_expr ();
2083 res
->where
= e1
->where
;
2084 res
->expr_type
= EXPR_OP
;
2085 res
->value
.op
.op
= op
;
2086 res
->value
.op
.op1
= e1
;
2087 res
->value
.op
.op2
= e2
;
2094 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2095 compatible typespecs. */
2098 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2102 res
= gfc_get_expr ();
2104 res
->where
= e1
->where
;
2105 res
->expr_type
= EXPR_OP
;
2106 res
->value
.op
.op
= op
;
2107 res
->value
.op
.op1
= e1
;
2108 res
->value
.op
.op2
= e2
;
2109 gfc_simplify_expr (res
, 0);
2113 /* Generate the IF statement for a runtime check if we want to do inlining or
2114 not - putting in the code for both branches and putting it into the syntax
2115 tree is the caller's responsibility. For fixed array sizes, this should be
2116 removed by DCE. Only called for rank-two matrices A and B. */
2119 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2121 gfc_expr
*inline_limit
;
2122 gfc_code
*if_1
, *if_2
, *else_2
;
2123 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2127 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
);
2129 /* Calculation is done in real to avoid integer overflow. */
2131 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2133 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2135 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2138 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2139 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2140 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2144 ts
.kind
= gfc_default_real_kind
;
2145 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2146 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2147 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2149 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2150 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2152 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2153 gfc_simplify_expr (cond
, 0);
2155 else_2
= XCNEW (gfc_code
);
2156 else_2
->op
= EXEC_IF
;
2157 else_2
->loc
= a
->where
;
2159 if_2
= XCNEW (gfc_code
);
2162 if_2
->loc
= a
->where
;
2163 if_2
->block
= else_2
;
2165 if_1
= XCNEW (gfc_code
);
2168 if_1
->loc
= a
->where
;
2174 /* Insert code to issue a runtime error if the expressions are not equal. */
2177 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2180 gfc_code
*if_1
, *if_2
;
2182 gfc_actual_arglist
*a1
, *a2
, *a3
;
2184 gcc_assert (e1
->where
.lb
);
2185 /* Build the call to runtime_error. */
2186 c
= XCNEW (gfc_code
);
2190 /* Get a null-terminated message string. */
2192 a1
= gfc_get_actual_arglist ();
2193 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2194 msg
, strlen(msg
)+1);
2197 /* Pass the value of the first expression. */
2198 a2
= gfc_get_actual_arglist ();
2199 a2
->expr
= gfc_copy_expr (e1
);
2202 /* Pass the value of the second expression. */
2203 a3
= gfc_get_actual_arglist ();
2204 a3
->expr
= gfc_copy_expr (e2
);
2207 gfc_check_fe_runtime_error (c
->ext
.actual
);
2208 gfc_resolve_fe_runtime_error (c
);
2210 if_2
= XCNEW (gfc_code
);
2212 if_2
->loc
= e1
->where
;
2215 if_1
= XCNEW (gfc_code
);
2218 if_1
->loc
= e1
->where
;
2220 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2221 gfc_simplify_expr (cond
, 0);
2227 /* Handle matrix reallocation. Caller is responsible to insert into
2230 For the two-dimensional case, build
2232 if (allocated(c)) then
2233 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2235 allocate (c(size(a,1), size(b,2)))
2238 allocate (c(size(a,1),size(b,2)))
2241 and for the other cases correspondingly.
2245 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2246 enum matrix_case m_case
)
2249 gfc_expr
*allocated
, *alloc_expr
;
2250 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2251 gfc_code
*else_alloc
;
2252 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2254 gfc_expr
*cond
, *ne1
, *ne2
;
2256 if (warn_realloc_lhs
)
2257 gfc_warning (OPT_Wrealloc_lhs
,
2258 "Code for reallocating the allocatable array at %L will "
2259 "be added", &c
->where
);
2261 alloc_expr
= gfc_copy_expr (c
);
2263 ar
= gfc_find_array_ref (alloc_expr
);
2264 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2266 /* c comes in as a full ref. Change it into a copy and make it into an
2267 element ref so it has the right form for for ALLOCATE. In the same
2268 switch statement, also generate the size comparison for the secod IF
2271 ar
->type
= AR_ELEMENT
;
2276 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2277 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2278 ne1
= build_logical_expr (INTRINSIC_NE
,
2279 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2280 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2281 ne2
= build_logical_expr (INTRINSIC_NE
,
2282 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2283 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2284 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2288 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2289 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2291 ne1
= build_logical_expr (INTRINSIC_NE
,
2292 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2293 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2294 ne2
= build_logical_expr (INTRINSIC_NE
,
2295 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2296 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2297 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2301 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2302 cond
= build_logical_expr (INTRINSIC_NE
,
2303 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2304 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2308 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2309 cond
= build_logical_expr (INTRINSIC_NE
,
2310 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2311 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2319 gfc_simplify_expr (cond
, 0);
2321 /* We need two identical allocate statements in two
2322 branches of the IF statement. */
2324 allocate1
= XCNEW (gfc_code
);
2325 allocate1
->op
= EXEC_ALLOCATE
;
2326 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2327 allocate1
->loc
= c
->where
;
2328 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2330 allocate_else
= XCNEW (gfc_code
);
2331 allocate_else
->op
= EXEC_ALLOCATE
;
2332 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2333 allocate_else
->loc
= c
->where
;
2334 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2336 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2337 "_gfortran_allocated", c
->where
,
2338 1, gfc_copy_expr (c
));
2340 deallocate
= XCNEW (gfc_code
);
2341 deallocate
->op
= EXEC_DEALLOCATE
;
2342 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2343 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2344 deallocate
->next
= allocate1
;
2345 deallocate
->loc
= c
->where
;
2347 if_size_2
= XCNEW (gfc_code
);
2348 if_size_2
->op
= EXEC_IF
;
2349 if_size_2
->expr1
= cond
;
2350 if_size_2
->loc
= c
->where
;
2351 if_size_2
->next
= deallocate
;
2353 if_size_1
= XCNEW (gfc_code
);
2354 if_size_1
->op
= EXEC_IF
;
2355 if_size_1
->block
= if_size_2
;
2356 if_size_1
->loc
= c
->where
;
2358 else_alloc
= XCNEW (gfc_code
);
2359 else_alloc
->op
= EXEC_IF
;
2360 else_alloc
->loc
= c
->where
;
2361 else_alloc
->next
= allocate_else
;
2363 if_alloc_2
= XCNEW (gfc_code
);
2364 if_alloc_2
->op
= EXEC_IF
;
2365 if_alloc_2
->expr1
= allocated
;
2366 if_alloc_2
->loc
= c
->where
;
2367 if_alloc_2
->next
= if_size_1
;
2368 if_alloc_2
->block
= else_alloc
;
2370 if_alloc_1
= XCNEW (gfc_code
);
2371 if_alloc_1
->op
= EXEC_IF
;
2372 if_alloc_1
->block
= if_alloc_2
;
2373 if_alloc_1
->loc
= c
->where
;
2378 /* Callback function for has_function_or_op. */
2381 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2382 void *data ATTRIBUTE_UNUSED
)
2387 return (*e
)->expr_type
== EXPR_FUNCTION
2388 || (*e
)->expr_type
== EXPR_OP
;
2391 /* Returns true if the expression contains a function. */
2394 has_function_or_op (gfc_expr
**e
)
2399 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2402 /* Freeze (assign to a temporary variable) a single expression. */
2405 freeze_expr (gfc_expr
**ep
)
2408 if (has_function_or_op (ep
))
2410 ne
= create_var (*ep
, "freeze");
2415 /* Go through an expression's references and assign them to temporary
2416 variables if they contain functions. This is usually done prior to
2417 front-end scalarization to avoid multiple invocations of functions. */
2420 freeze_references (gfc_expr
*e
)
2426 for (r
=e
->ref
; r
; r
=r
->next
)
2428 if (r
->type
== REF_SUBSTRING
)
2430 if (r
->u
.ss
.start
!= NULL
)
2431 freeze_expr (&r
->u
.ss
.start
);
2433 if (r
->u
.ss
.end
!= NULL
)
2434 freeze_expr (&r
->u
.ss
.end
);
2436 else if (r
->type
== REF_ARRAY
)
2445 for (i
=0; i
<ar
->dimen
; i
++)
2447 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2449 freeze_expr (&ar
->start
[i
]);
2450 freeze_expr (&ar
->end
[i
]);
2451 freeze_expr (&ar
->stride
[i
]);
2453 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2455 freeze_expr (&ar
->start
[i
]);
2461 for (i
=0; i
<ar
->dimen
; i
++)
2462 freeze_expr (&ar
->start
[i
]);
2472 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2475 convert_to_index_kind (gfc_expr
*e
)
2479 gcc_assert (e
!= NULL
);
2481 res
= gfc_copy_expr (e
);
2483 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2485 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2489 ts
.type
= BT_INTEGER
;
2490 ts
.kind
= gfc_index_integer_kind
;
2492 gfc_convert_type_warn (e
, &ts
, 2, 0);
2498 /* Function to create a DO loop including creation of the
2499 iteration variable. gfc_expr are copied.*/
2502 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2503 gfc_namespace
*ns
, char *vname
)
2506 char name
[GFC_MAX_SYMBOL_LEN
+1];
2507 gfc_symtree
*symtree
;
2512 /* Create an expression for the iteration variable. */
2514 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2516 sprintf (name
, "__var_%d_do", var_num
++);
2519 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2522 /* Create the loop variable. */
2524 symbol
= symtree
->n
.sym
;
2525 symbol
->ts
.type
= BT_INTEGER
;
2526 symbol
->ts
.kind
= gfc_index_integer_kind
;
2527 symbol
->attr
.flavor
= FL_VARIABLE
;
2528 symbol
->attr
.referenced
= 1;
2529 symbol
->attr
.dimension
= 0;
2530 symbol
->attr
.fe_temp
= 1;
2531 gfc_commit_symbol (symbol
);
2533 i
= gfc_get_expr ();
2534 i
->expr_type
= EXPR_VARIABLE
;
2538 i
->symtree
= symtree
;
2540 /* ... and the nested DO statements. */
2541 n
= XCNEW (gfc_code
);
2544 n
->ext
.iterator
= gfc_get_iterator ();
2545 n
->ext
.iterator
->var
= i
;
2546 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2547 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2549 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2551 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2554 n2
= XCNEW (gfc_code
);
2562 /* Get the upper bound of the DO loops for matmul along a dimension. This
2566 get_size_m1 (gfc_expr
*e
, int dimen
)
2571 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2573 res
= gfc_get_constant_expr (BT_INTEGER
,
2574 gfc_index_integer_kind
, &e
->where
);
2575 mpz_sub_ui (res
->value
.integer
, size
, 1);
2580 res
= get_operand (INTRINSIC_MINUS
,
2581 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2582 gfc_get_int_expr (gfc_index_integer_kind
,
2584 gfc_simplify_expr (res
, 0);
2590 /* Function to return a scalarized expression. It is assumed that indices are
2591 zero based to make generation of DO loops easier. A zero as index will
2592 access the first element along a dimension. Single element references will
2593 be skipped. A NULL as an expression will be replaced by a full reference.
2594 This assumes that the index loops have gfc_index_integer_kind, and that all
2595 references have been frozen. */
2598 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2607 e
= gfc_copy_expr(e_in
);
2611 ar
= gfc_find_array_ref (e
);
2613 /* We scalarize count_index variables, reducing the rank by count_index. */
2615 e
->rank
= rank
- count_index
;
2617 was_fullref
= ar
->type
== AR_FULL
;
2620 ar
->type
= AR_ELEMENT
;
2622 ar
->type
= AR_SECTION
;
2624 /* Loop over the indices. For each index, create the expression
2625 index * stride + lbound(e, dim). */
2628 for (i
=0; i
< ar
->dimen
; i
++)
2630 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2632 if (index
[i_index
] != NULL
)
2634 gfc_expr
*lbound
, *nindex
;
2637 loopvar
= gfc_copy_expr (index
[i_index
]);
2643 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2644 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2648 ts
.type
= BT_INTEGER
;
2649 ts
.kind
= gfc_index_integer_kind
;
2650 gfc_convert_type (tmp
, &ts
, 2);
2652 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2657 /* Calculate the lower bound of the expression. */
2660 lbound
= gfc_copy_expr (ar
->start
[i
]);
2661 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2665 ts
.type
= BT_INTEGER
;
2666 ts
.kind
= gfc_index_integer_kind
;
2667 gfc_convert_type (lbound
, &ts
, 2);
2676 lbound_e
= gfc_copy_expr (e_in
);
2678 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2679 if (ref
->type
== REF_ARRAY
2680 && (ref
->u
.ar
.type
== AR_FULL
2681 || ref
->u
.ar
.type
== AR_SECTION
))
2686 gfc_free_ref_list (ref
->next
);
2692 /* Look at full individual sections, like a(:). The first index
2693 is the lbound of a full ref. */
2699 for (j
= 0; j
< ar
->dimen
; j
++)
2701 gfc_free_expr (ar
->start
[j
]);
2702 ar
->start
[j
] = NULL
;
2703 gfc_free_expr (ar
->end
[j
]);
2705 gfc_free_expr (ar
->stride
[j
]);
2706 ar
->stride
[j
] = NULL
;
2709 /* We have to get rid of the shape, if there is one. Do
2710 so by freeing it and calling gfc_resolve to rebuild
2711 it, if necessary. */
2713 if (lbound_e
->shape
)
2714 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2716 lbound_e
->rank
= ar
->dimen
;
2717 gfc_resolve_expr (lbound_e
);
2719 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2721 gfc_free_expr (lbound_e
);
2724 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2726 gfc_free_expr (ar
->start
[i
]);
2727 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2729 gfc_free_expr (ar
->end
[i
]);
2731 gfc_free_expr (ar
->stride
[i
]);
2732 ar
->stride
[i
] = NULL
;
2733 gfc_simplify_expr (ar
->start
[i
], 0);
2735 else if (was_fullref
)
2737 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2746 /* Helper function to check for a dimen vector as subscript. */
2749 has_dimen_vector_ref (gfc_expr
*e
)
2754 ar
= gfc_find_array_ref (e
);
2756 if (ar
->type
== AR_FULL
)
2759 for (i
=0; i
<ar
->dimen
; i
++)
2760 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2766 /* If handed an expression of the form
2770 check if A can be handled by matmul and return if there is an uneven number
2771 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2772 otherwise. The caller has to check for the correct rank. */
2775 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2782 if (e
->expr_type
== EXPR_VARIABLE
)
2784 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2787 else if (e
->expr_type
== EXPR_FUNCTION
)
2789 if (e
->value
.function
.isym
== NULL
)
2792 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2794 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2795 *transpose
= !*transpose
;
2801 e
= e
->value
.function
.actual
->expr
;
2808 /* Inline assignments of the form c = matmul(a,b).
2809 Handle only the cases currently where b and c are rank-two arrays.
2811 This basically translates the code to
2817 do k=0, size(a, 2)-1
2818 do i=0, size(a, 1)-1
2819 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2820 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2821 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2822 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2831 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2832 void *data ATTRIBUTE_UNUSED
)
2835 gfc_expr
*expr1
, *expr2
;
2836 gfc_expr
*matrix_a
, *matrix_b
;
2837 gfc_actual_arglist
*a
, *b
;
2838 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2840 gfc_expr
*u1
, *u2
, *u3
;
2842 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2844 gfc_expr
*var_1
, *var_2
, *var_3
;
2847 gfc_intrinsic_op op_times
, op_plus
;
2848 enum matrix_case m_case
;
2850 gfc_code
*if_limit
= NULL
;
2851 gfc_code
**next_code_point
;
2852 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2854 if (co
->op
!= EXEC_ASSIGN
)
2860 /* The BLOCKS generated for the temporary variables and FORALL don't
2862 if (forall_level
> 0)
2865 /* For now don't do anything in OpenMP workshare, it confuses
2866 its translation, which expects only the allowed statements in there.
2867 We should figure out how to parallelize this eventually. */
2868 if (in_omp_workshare
)
2873 if (expr2
->expr_type
!= EXPR_FUNCTION
2874 || expr2
->value
.function
.isym
== NULL
2875 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2879 inserted_block
= NULL
;
2880 changed_statement
= NULL
;
2882 a
= expr2
->value
.function
.actual
;
2883 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2884 if (transpose_a
|| matrix_a
== NULL
)
2888 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2889 if (matrix_b
== NULL
)
2892 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
2893 || has_dimen_vector_ref (matrix_b
))
2896 /* We do not handle data dependencies yet. */
2897 if (gfc_check_dependency (expr1
, matrix_a
, true)
2898 || gfc_check_dependency (expr1
, matrix_b
, true))
2901 if (matrix_a
->rank
== 2)
2903 if (matrix_b
->rank
== 1)
2915 /* Vector * Transpose(B) not handled yet. */
2925 ns
= insert_block ();
2927 /* Assign the type of the zero expression for initializing the resulting
2928 array, and the expression (+ and * for real, integer and complex;
2929 .and. and .or for logical. */
2931 switch(expr1
->ts
.type
)
2934 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
2935 op_times
= INTRINSIC_TIMES
;
2936 op_plus
= INTRINSIC_PLUS
;
2940 op_times
= INTRINSIC_AND
;
2941 op_plus
= INTRINSIC_OR
;
2942 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
2946 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
2948 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
2949 op_times
= INTRINSIC_TIMES
;
2950 op_plus
= INTRINSIC_PLUS
;
2954 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
2956 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
2957 op_times
= INTRINSIC_TIMES
;
2958 op_plus
= INTRINSIC_PLUS
;
2966 current_code
= &ns
->code
;
2968 /* Freeze the references, keeping track of how many temporary variables were
2971 freeze_references (matrix_a
);
2972 freeze_references (matrix_b
);
2973 freeze_references (expr1
);
2976 next_code_point
= current_code
;
2979 next_code_point
= &ns
->code
;
2980 for (i
=0; i
<n_vars
; i
++)
2981 next_code_point
= &(*next_code_point
)->next
;
2984 /* Take care of the inline flag. If the limit check evaluates to a
2985 constant, dead code elimination will eliminate the unneeded branch. */
2987 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
2989 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
2991 /* Insert the original statement into the else branch. */
2992 if_limit
->block
->block
->next
= co
;
2995 /* ... and the new ones go into the original one. */
2996 *next_code_point
= if_limit
;
2997 next_code_point
= &if_limit
->block
->next
;
3000 assign_zero
= XCNEW (gfc_code
);
3001 assign_zero
->op
= EXEC_ASSIGN
;
3002 assign_zero
->loc
= co
->loc
;
3003 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3004 assign_zero
->expr2
= zero_e
;
3006 /* Handle the reallocation, if needed. */
3007 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3009 gfc_code
*lhs_alloc
;
3011 /* Only need to check a single dimension for the A2B2 case for
3012 bounds checking, the rest will be allocated. */
3014 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
&& m_case
== A2B2
)
3019 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3020 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3021 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3022 "in MATMUL intrinsic: Is %ld, should be %ld");
3023 *next_code_point
= test
;
3024 next_code_point
= &test
->next
;
3028 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3030 *next_code_point
= lhs_alloc
;
3031 next_code_point
= &lhs_alloc
->next
;
3034 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3037 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3039 if (m_case
== A2B2
|| m_case
== A2B1
)
3041 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3042 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3043 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3044 "in MATMUL intrinsic: Is %ld, should be %ld");
3045 *next_code_point
= test
;
3046 next_code_point
= &test
->next
;
3048 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3049 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3052 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3053 "MATMUL intrinsic for dimension 1: "
3054 "is %ld, should be %ld");
3055 else if (m_case
== A2B1
)
3056 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3057 "MATMUL intrinsic: "
3058 "is %ld, should be %ld");
3061 *next_code_point
= test
;
3062 next_code_point
= &test
->next
;
3064 else if (m_case
== A1B2
)
3066 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3067 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3068 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3069 "in MATMUL intrinsic: Is %ld, should be %ld");
3070 *next_code_point
= test
;
3071 next_code_point
= &test
->next
;
3073 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3074 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3076 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3077 "MATMUL intrinsic: "
3078 "is %ld, should be %ld");
3080 *next_code_point
= test
;
3081 next_code_point
= &test
->next
;
3086 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3087 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3088 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3089 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3091 *next_code_point
= test
;
3092 next_code_point
= &test
->next
;
3095 if (m_case
== A2B2T
)
3097 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3098 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3099 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3100 "MATMUL intrinsic for dimension 1: "
3101 "is %ld, should be %ld");
3103 *next_code_point
= test
;
3104 next_code_point
= &test
->next
;
3106 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3107 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3108 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3109 "MATMUL intrinsic for dimension 2: "
3110 "is %ld, should be %ld");
3111 *next_code_point
= test
;
3112 next_code_point
= &test
->next
;
3114 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3115 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3117 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3118 "MATMUL intrnisic for dimension 2: "
3119 "is %ld, should be %ld");
3120 *next_code_point
= test
;
3121 next_code_point
= &test
->next
;
3126 *next_code_point
= assign_zero
;
3128 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3130 assign_matmul
= XCNEW (gfc_code
);
3131 assign_matmul
->op
= EXEC_ASSIGN
;
3132 assign_matmul
->loc
= co
->loc
;
3134 /* Get the bounds for the loops, create them and create the scalarized
3140 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3142 u1
= get_size_m1 (matrix_b
, 2);
3143 u2
= get_size_m1 (matrix_a
, 2);
3144 u3
= get_size_m1 (matrix_a
, 1);
3146 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3147 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3148 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3150 do_1
->block
->next
= do_2
;
3151 do_2
->block
->next
= do_3
;
3152 do_3
->block
->next
= assign_matmul
;
3154 var_1
= do_1
->ext
.iterator
->var
;
3155 var_2
= do_2
->ext
.iterator
->var
;
3156 var_3
= do_3
->ext
.iterator
->var
;
3160 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3164 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3168 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3173 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3175 u1
= get_size_m1 (matrix_b
, 1);
3176 u2
= get_size_m1 (matrix_a
, 2);
3177 u3
= get_size_m1 (matrix_a
, 1);
3179 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3180 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3181 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3183 do_1
->block
->next
= do_2
;
3184 do_2
->block
->next
= do_3
;
3185 do_3
->block
->next
= assign_matmul
;
3187 var_1
= do_1
->ext
.iterator
->var
;
3188 var_2
= do_2
->ext
.iterator
->var
;
3189 var_3
= do_3
->ext
.iterator
->var
;
3193 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3197 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3201 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3206 u1
= get_size_m1 (matrix_b
, 1);
3207 u2
= get_size_m1 (matrix_a
, 1);
3209 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3210 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3212 do_1
->block
->next
= do_2
;
3213 do_2
->block
->next
= assign_matmul
;
3215 var_1
= do_1
->ext
.iterator
->var
;
3216 var_2
= do_2
->ext
.iterator
->var
;
3219 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3223 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3226 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3231 u1
= get_size_m1 (matrix_b
, 2);
3232 u2
= get_size_m1 (matrix_a
, 1);
3234 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3235 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3237 do_1
->block
->next
= do_2
;
3238 do_2
->block
->next
= assign_matmul
;
3240 var_1
= do_1
->ext
.iterator
->var
;
3241 var_2
= do_2
->ext
.iterator
->var
;
3244 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3247 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3251 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3260 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3261 matrix_a
->where
, 1, ascalar
);
3264 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3265 matrix_b
->where
, 1, bscalar
);
3267 /* First loop comes after the zero assignment. */
3268 assign_zero
->next
= do_1
;
3270 /* Build the assignment expression in the loop. */
3271 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3273 mult
= get_operand (op_times
, ascalar
, bscalar
);
3274 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3276 /* If we don't want to keep the original statement around in
3277 the else branch, we can free it. */
3279 if (if_limit
== NULL
)
3280 gfc_free_statements(co
);
3284 gfc_free_expr (zero
);
3289 #define WALK_SUBEXPR(NODE) \
3292 result = gfc_expr_walker (&(NODE), exprfn, data); \
3297 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3299 /* Walk expression *E, calling EXPRFN on each expression in it. */
3302 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3306 int walk_subtrees
= 1;
3307 gfc_actual_arglist
*a
;
3311 int result
= exprfn (e
, &walk_subtrees
, data
);
3315 switch ((*e
)->expr_type
)
3318 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3319 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3322 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3323 WALK_SUBEXPR (a
->expr
);
3327 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3328 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3329 WALK_SUBEXPR (a
->expr
);
3332 case EXPR_STRUCTURE
:
3334 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3335 c
= gfc_constructor_next (c
))
3337 if (c
->iterator
== NULL
)
3338 WALK_SUBEXPR (c
->expr
);
3342 WALK_SUBEXPR (c
->expr
);
3344 WALK_SUBEXPR (c
->iterator
->var
);
3345 WALK_SUBEXPR (c
->iterator
->start
);
3346 WALK_SUBEXPR (c
->iterator
->end
);
3347 WALK_SUBEXPR (c
->iterator
->step
);
3351 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3354 /* Fall through to the variable case in order to walk the
3358 case EXPR_SUBSTRING
:
3360 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3369 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3371 for (i
=0; i
< ar
->dimen
; i
++)
3373 WALK_SUBEXPR (ar
->start
[i
]);
3374 WALK_SUBEXPR (ar
->end
[i
]);
3375 WALK_SUBEXPR (ar
->stride
[i
]);
3382 WALK_SUBEXPR (r
->u
.ss
.start
);
3383 WALK_SUBEXPR (r
->u
.ss
.end
);
3399 #define WALK_SUBCODE(NODE) \
3402 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3408 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3409 on each expression in it. If any of the hooks returns non-zero, that
3410 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3411 no subcodes or subexpressions are traversed. */
3414 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3417 for (; *c
; c
= &(*c
)->next
)
3419 int walk_subtrees
= 1;
3420 int result
= codefn (c
, &walk_subtrees
, data
);
3427 gfc_actual_arglist
*a
;
3429 gfc_association_list
*alist
;
3430 bool saved_in_omp_workshare
;
3431 bool saved_in_where
;
3433 /* There might be statement insertions before the current code,
3434 which must not affect the expression walker. */
3437 saved_in_omp_workshare
= in_omp_workshare
;
3438 saved_in_where
= in_where
;
3444 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3445 if (co
->ext
.block
.assoc
)
3447 bool saved_in_assoc_list
= in_assoc_list
;
3449 in_assoc_list
= true;
3450 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3451 WALK_SUBEXPR (alist
->target
);
3453 in_assoc_list
= saved_in_assoc_list
;
3460 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3461 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3462 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3463 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3471 case EXEC_ASSIGN_CALL
:
3472 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3473 WALK_SUBEXPR (a
->expr
);
3477 WALK_SUBEXPR (co
->expr1
);
3478 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3479 WALK_SUBEXPR (a
->expr
);
3483 WALK_SUBEXPR (co
->expr1
);
3484 for (b
= co
->block
; b
; b
= b
->block
)
3487 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3489 WALK_SUBEXPR (cp
->low
);
3490 WALK_SUBEXPR (cp
->high
);
3492 WALK_SUBCODE (b
->next
);
3497 case EXEC_DEALLOCATE
:
3500 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3501 WALK_SUBEXPR (a
->expr
);
3506 case EXEC_DO_CONCURRENT
:
3508 gfc_forall_iterator
*fa
;
3509 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3511 WALK_SUBEXPR (fa
->var
);
3512 WALK_SUBEXPR (fa
->start
);
3513 WALK_SUBEXPR (fa
->end
);
3514 WALK_SUBEXPR (fa
->stride
);
3516 if (co
->op
== EXEC_FORALL
)
3522 WALK_SUBEXPR (co
->ext
.open
->unit
);
3523 WALK_SUBEXPR (co
->ext
.open
->file
);
3524 WALK_SUBEXPR (co
->ext
.open
->status
);
3525 WALK_SUBEXPR (co
->ext
.open
->access
);
3526 WALK_SUBEXPR (co
->ext
.open
->form
);
3527 WALK_SUBEXPR (co
->ext
.open
->recl
);
3528 WALK_SUBEXPR (co
->ext
.open
->blank
);
3529 WALK_SUBEXPR (co
->ext
.open
->position
);
3530 WALK_SUBEXPR (co
->ext
.open
->action
);
3531 WALK_SUBEXPR (co
->ext
.open
->delim
);
3532 WALK_SUBEXPR (co
->ext
.open
->pad
);
3533 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3534 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3535 WALK_SUBEXPR (co
->ext
.open
->convert
);
3536 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3537 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3538 WALK_SUBEXPR (co
->ext
.open
->round
);
3539 WALK_SUBEXPR (co
->ext
.open
->sign
);
3540 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3541 WALK_SUBEXPR (co
->ext
.open
->id
);
3542 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3543 WALK_SUBEXPR (co
->ext
.open
->share
);
3544 WALK_SUBEXPR (co
->ext
.open
->cc
);
3548 WALK_SUBEXPR (co
->ext
.close
->unit
);
3549 WALK_SUBEXPR (co
->ext
.close
->status
);
3550 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3551 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3554 case EXEC_BACKSPACE
:
3558 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3559 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3560 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3564 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3565 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3566 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3567 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3568 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3569 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3570 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3571 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3572 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3573 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3574 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3575 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3576 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3577 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3578 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3579 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3580 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3581 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3582 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3583 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3584 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3585 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3586 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3587 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3588 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3589 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3590 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3591 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3592 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3593 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3594 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3595 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3596 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3597 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3598 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3599 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3603 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3604 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3605 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3606 WALK_SUBEXPR (co
->ext
.wait
->id
);
3611 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3612 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3613 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3614 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3615 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3616 WALK_SUBEXPR (co
->ext
.dt
->size
);
3617 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3618 WALK_SUBEXPR (co
->ext
.dt
->id
);
3619 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3620 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3621 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3622 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3623 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3624 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3625 WALK_SUBEXPR (co
->ext
.dt
->round
);
3626 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3627 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3630 case EXEC_OMP_PARALLEL
:
3631 case EXEC_OMP_PARALLEL_DO
:
3632 case EXEC_OMP_PARALLEL_DO_SIMD
:
3633 case EXEC_OMP_PARALLEL_SECTIONS
:
3635 in_omp_workshare
= false;
3637 /* This goto serves as a shortcut to avoid code
3638 duplication or a larger if or switch statement. */
3639 goto check_omp_clauses
;
3641 case EXEC_OMP_WORKSHARE
:
3642 case EXEC_OMP_PARALLEL_WORKSHARE
:
3644 in_omp_workshare
= true;
3648 case EXEC_OMP_DISTRIBUTE
:
3649 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3650 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3651 case EXEC_OMP_DISTRIBUTE_SIMD
:
3653 case EXEC_OMP_DO_SIMD
:
3654 case EXEC_OMP_SECTIONS
:
3655 case EXEC_OMP_SINGLE
:
3656 case EXEC_OMP_END_SINGLE
:
3658 case EXEC_OMP_TARGET
:
3659 case EXEC_OMP_TARGET_DATA
:
3660 case EXEC_OMP_TARGET_TEAMS
:
3661 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3662 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3663 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3664 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3665 case EXEC_OMP_TARGET_UPDATE
:
3667 case EXEC_OMP_TEAMS
:
3668 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3669 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3670 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3671 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3673 /* Come to this label only from the
3674 EXEC_OMP_PARALLEL_* cases above. */
3678 if (co
->ext
.omp_clauses
)
3680 gfc_omp_namelist
*n
;
3681 static int list_types
[]
3682 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3683 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3685 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3686 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3687 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3688 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3689 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3690 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3691 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3692 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3693 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3694 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3696 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3698 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3700 WALK_SUBEXPR (n
->expr
);
3707 WALK_SUBEXPR (co
->expr1
);
3708 WALK_SUBEXPR (co
->expr2
);
3709 WALK_SUBEXPR (co
->expr3
);
3710 WALK_SUBEXPR (co
->expr4
);
3711 for (b
= co
->block
; b
; b
= b
->block
)
3713 WALK_SUBEXPR (b
->expr1
);
3714 WALK_SUBEXPR (b
->expr2
);
3715 WALK_SUBCODE (b
->next
);
3718 if (co
->op
== EXEC_FORALL
)
3721 if (co
->op
== EXEC_DO
)
3724 in_omp_workshare
= saved_in_omp_workshare
;
3725 in_where
= saved_in_where
;