1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2018 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 int do_intent (gfc_expr
**);
43 static int do_subscript (gfc_expr
**);
44 static void optimize_reduction (gfc_namespace
*);
45 static int callback_reduction (gfc_expr
**, int *, void *);
46 static void realloc_strings (gfc_namespace
*);
47 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
48 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
49 static int matmul_to_var_code (gfc_code
**, int *, void *);
50 static int inline_matmul_assign (gfc_code
**, int *, void *);
51 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
52 locus
*, gfc_namespace
*,
54 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
56 static int call_external_blas (gfc_code
**, int *, void *);
57 static bool has_dimen_vector_ref (gfc_expr
*);
58 static int matmul_temp_args (gfc_code
**, int *,void *data
);
59 static int index_interchange (gfc_code
**, int*, void *);
61 static bool is_fe_temp (gfc_expr
*e
);
64 static void check_locus (gfc_namespace
*);
67 /* How deep we are inside an argument list. */
69 static int count_arglist
;
71 /* Vector of gfc_expr ** we operate on. */
73 static vec
<gfc_expr
**> expr_array
;
75 /* Pointer to the gfc_code we currently work on - to be able to insert
76 a block before the statement. */
78 static gfc_code
**current_code
;
80 /* Pointer to the block to be inserted, and the statement we are
81 changing within the block. */
83 static gfc_code
*inserted_block
, **changed_statement
;
85 /* The namespace we are currently dealing with. */
87 static gfc_namespace
*current_ns
;
89 /* If we are within any forall loop. */
91 static int forall_level
;
93 /* Keep track of whether we are within an OMP workshare. */
95 static bool in_omp_workshare
;
97 /* Keep track of whether we are within a WHERE statement. */
101 /* Keep track of iterators for array constructors. */
103 static int iterator_level
;
105 /* Keep track of DO loop levels. */
113 static vec
<do_t
> doloop_list
;
114 static int doloop_level
;
116 /* Keep track of if and select case levels. */
119 static int select_level
;
121 /* Vector of gfc_expr * to keep track of DO loops. */
123 struct my_struct
*evec
;
125 /* Keep track of association lists. */
127 static bool in_assoc_list
;
129 /* Counter for temporary variables. */
131 static int var_num
= 1;
133 /* What sort of matrix we are dealing with when inlining MATMUL. */
135 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
, A2TB2T
};
137 /* Keep track of the number of expressions we have inserted so far
142 /* Entry point - run all passes for a namespace. */
145 gfc_run_passes (gfc_namespace
*ns
)
148 /* Warn about dubious DO loops where the index might
155 doloop_list
.release ();
162 gfc_get_errors (&w
, &e
);
166 if (flag_frontend_optimize
|| flag_frontend_loop_interchange
)
167 optimize_namespace (ns
);
169 if (flag_frontend_optimize
)
171 optimize_reduction (ns
);
172 if (flag_dump_fortran_optimized
)
173 gfc_dump_parse_tree (ns
, stdout
);
175 expr_array
.release ();
178 if (flag_realloc_lhs
)
179 realloc_strings (ns
);
184 /* Callback function: Warn if there is no location information in a
188 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
189 void *data ATTRIBUTE_UNUSED
)
192 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
193 gfc_warning_internal (0, "No location in statement");
199 /* Callback function: Warn if there is no location information in an
203 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
204 void *data ATTRIBUTE_UNUSED
)
207 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
208 gfc_warning_internal (0, "No location in expression near %L",
209 &((*current_code
)->loc
));
213 /* Run check for missing location information. */
216 check_locus (gfc_namespace
*ns
)
218 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
220 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
222 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
229 /* Callback for each gfc_code node invoked from check_realloc_strings.
230 For an allocatable LHS string which also appears as a variable on
242 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
243 void *data ATTRIBUTE_UNUSED
)
245 gfc_expr
*expr1
, *expr2
;
251 if (co
->op
!= EXEC_ASSIGN
)
255 if (expr1
->ts
.type
!= BT_CHARACTER
256 || !gfc_expr_attr(expr1
).allocatable
257 || !expr1
->ts
.deferred
)
260 if (is_fe_temp (expr1
))
263 expr2
= gfc_discard_nops (co
->expr2
);
265 if (expr2
->expr_type
== EXPR_VARIABLE
)
267 found_substr
= false;
268 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
270 if (ref
->type
== REF_SUBSTRING
)
279 else if (expr2
->expr_type
!= EXPR_ARRAY
280 && (expr2
->expr_type
!= EXPR_OP
281 || expr2
->value
.op
.op
!= INTRINSIC_CONCAT
))
284 if (!gfc_check_dependency (expr1
, expr2
, true))
287 /* gfc_check_dependency doesn't always pick up identical expressions.
288 However, eliminating the above sends the compiler into an infinite
289 loop on valid expressions. Without this check, the gimplifier emits
290 an ICE for a = a, where a is deferred character length. */
291 if (!gfc_dep_compare_expr (expr1
, expr2
))
295 inserted_block
= NULL
;
296 changed_statement
= NULL
;
297 n
= create_var (expr2
, "realloc_string");
302 /* Callback for each gfc_code node invoked through gfc_code_walker
303 from optimize_namespace. */
306 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
307 void *data ATTRIBUTE_UNUSED
)
314 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
315 || op
== EXEC_CALL_PPC
)
321 inserted_block
= NULL
;
322 changed_statement
= NULL
;
324 if (op
== EXEC_ASSIGN
)
325 optimize_assignment (*c
);
329 /* Callback for each gfc_expr node invoked through gfc_code_walker
330 from optimize_namespace. */
333 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
334 void *data ATTRIBUTE_UNUSED
)
338 if ((*e
)->expr_type
== EXPR_FUNCTION
)
341 function_expr
= true;
344 function_expr
= false;
346 if (optimize_trim (*e
))
347 gfc_simplify_expr (*e
, 0);
349 if (optimize_lexical_comparison (*e
))
350 gfc_simplify_expr (*e
, 0);
352 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
353 gfc_simplify_expr (*e
, 0);
355 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
356 switch ((*e
)->value
.function
.isym
->id
)
358 case GFC_ISYM_MINLOC
:
359 case GFC_ISYM_MAXLOC
:
360 optimize_minmaxloc (e
);
372 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
373 function is a scalar, just copy it; otherwise returns the new element, the
374 old one can be freed. */
377 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
379 gfc_expr
*fcn
, *e
= c
->expr
;
381 fcn
= gfc_copy_expr (e
);
384 gfc_constructor_base newbase
;
386 gfc_constructor
*new_c
;
389 new_expr
= gfc_get_expr ();
390 new_expr
->expr_type
= EXPR_ARRAY
;
391 new_expr
->ts
= e
->ts
;
392 new_expr
->where
= e
->where
;
394 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
395 new_c
->iterator
= c
->iterator
;
396 new_expr
->value
.constructor
= newbase
;
404 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
406 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
407 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
408 fn
->value
.function
.isym
->name
,
409 fn
->where
, 3, fcn
, NULL
, NULL
);
410 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
411 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
412 fn
->value
.function
.isym
->name
,
413 fn
->where
, 2, fcn
, NULL
);
415 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
417 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
423 /* Callback function for optimzation of reductions to scalars. Transform ANY
424 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
425 correspondingly. Handly only the simple cases without MASK and DIM. */
428 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
429 void *data ATTRIBUTE_UNUSED
)
434 gfc_actual_arglist
*a
;
435 gfc_actual_arglist
*dim
;
437 gfc_expr
*res
, *new_expr
;
438 gfc_actual_arglist
*mask
;
442 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
443 || fn
->value
.function
.isym
== NULL
)
446 id
= fn
->value
.function
.isym
->id
;
448 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
449 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
452 a
= fn
->value
.function
.actual
;
454 /* Don't handle MASK or DIM. */
458 if (dim
->expr
!= NULL
)
461 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
464 if ( mask
->expr
!= NULL
)
470 if (arg
->expr_type
!= EXPR_ARRAY
)
479 case GFC_ISYM_PRODUCT
:
480 op
= INTRINSIC_TIMES
;
495 c
= gfc_constructor_first (arg
->value
.constructor
);
497 /* Don't do any simplififcation if we have
498 - no element in the constructor or
499 - only have a single element in the array which contains an
505 res
= copy_walk_reduction_arg (c
, fn
);
507 c
= gfc_constructor_next (c
);
510 new_expr
= gfc_get_expr ();
511 new_expr
->ts
= fn
->ts
;
512 new_expr
->expr_type
= EXPR_OP
;
513 new_expr
->rank
= fn
->rank
;
514 new_expr
->where
= fn
->where
;
515 new_expr
->value
.op
.op
= op
;
516 new_expr
->value
.op
.op1
= res
;
517 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
519 c
= gfc_constructor_next (c
);
522 gfc_simplify_expr (res
, 0);
529 /* Callback function for common function elimination, called from cfe_expr_0.
530 Put all eligible function expressions into expr_array. */
533 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
534 void *data ATTRIBUTE_UNUSED
)
537 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
540 /* We don't do character functions with unknown charlens. */
541 if ((*e
)->ts
.type
== BT_CHARACTER
542 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
543 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
546 /* We don't do function elimination within FORALL statements, it can
547 lead to wrong-code in certain circumstances. */
549 if (forall_level
> 0)
552 /* Function elimination inside an iterator could lead to functions which
553 depend on iterator variables being moved outside. FIXME: We should check
554 if the functions do indeed depend on the iterator variable. */
556 if (iterator_level
> 0)
559 /* If we don't know the shape at compile time, we create an allocatable
560 temporary variable to hold the intermediate result, but only if
561 allocation on assignment is active. */
563 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
566 /* Skip the test for pure functions if -faggressive-function-elimination
568 if ((*e
)->value
.function
.esym
)
570 /* Don't create an array temporary for elemental functions. */
571 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
574 /* Only eliminate potentially impure functions if the
575 user specifically requested it. */
576 if (!flag_aggressive_function_elimination
577 && !(*e
)->value
.function
.esym
->attr
.pure
578 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
582 if ((*e
)->value
.function
.isym
)
584 /* Conversions are handled on the fly by the middle end,
585 transpose during trans-* stages and TRANSFER by the middle end. */
586 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
587 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
588 || gfc_inline_intrinsic_function_p (*e
))
591 /* Don't create an array temporary for elemental functions,
592 as this would be wasteful of memory.
593 FIXME: Create a scalar temporary during scalarization. */
594 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
597 if (!(*e
)->value
.function
.isym
->pure
)
601 expr_array
.safe_push (e
);
605 /* Auxiliary function to check if an expression is a temporary created by
609 is_fe_temp (gfc_expr
*e
)
611 if (e
->expr_type
!= EXPR_VARIABLE
)
614 return e
->symtree
->n
.sym
->attr
.fe_temp
;
617 /* Determine the length of a string, if it can be evaluated as a constant
618 expression. Return a newly allocated gfc_expr or NULL on failure.
619 If the user specified a substring which is potentially longer than
620 the string itself, the string will be padded with spaces, which
624 constant_string_length (gfc_expr
*e
)
634 length
= e
->ts
.u
.cl
->length
;
635 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
636 return gfc_copy_expr(length
);
639 /* Return length of substring, if constant. */
640 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
642 if (ref
->type
== REF_SUBSTRING
643 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
645 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
648 mpz_add_ui (res
->value
.integer
, value
, 1);
654 /* Return length of char symbol, if constant. */
656 if (e
->symtree
&& e
->symtree
->n
.sym
->ts
.u
.cl
657 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
658 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
659 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
665 /* Insert a block at the current position unless it has already
666 been inserted; in this case use the one already there. */
668 static gfc_namespace
*
673 /* If the block hasn't already been created, do so. */
674 if (inserted_block
== NULL
)
676 inserted_block
= XCNEW (gfc_code
);
677 inserted_block
->op
= EXEC_BLOCK
;
678 inserted_block
->loc
= (*current_code
)->loc
;
679 ns
= gfc_build_block_ns (current_ns
);
680 inserted_block
->ext
.block
.ns
= ns
;
681 inserted_block
->ext
.block
.assoc
= NULL
;
683 ns
->code
= *current_code
;
685 /* If the statement has a label, make sure it is transferred to
686 the newly created block. */
688 if ((*current_code
)->here
)
690 inserted_block
->here
= (*current_code
)->here
;
691 (*current_code
)->here
= NULL
;
694 inserted_block
->next
= (*current_code
)->next
;
695 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
696 (*current_code
)->next
= NULL
;
697 /* Insert the BLOCK at the right position. */
698 *current_code
= inserted_block
;
699 ns
->parent
= current_ns
;
702 ns
= inserted_block
->ext
.block
.ns
;
707 /* Returns a new expression (a variable) to be used in place of the old one,
708 with an optional assignment statement before the current statement to set
709 the value of the variable. Creates a new BLOCK for the statement if that
710 hasn't already been done and puts the statement, plus the newly created
711 variables, in that block. Special cases: If the expression is constant or
712 a temporary which has already been created, just copy it. */
715 create_var (gfc_expr
* e
, const char *vname
)
717 char name
[GFC_MAX_SYMBOL_LEN
+1];
718 gfc_symtree
*symtree
;
726 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
727 return gfc_copy_expr (e
);
729 /* Creation of an array of unknown size requires realloc on assignment.
730 If that is not possible, just return NULL. */
731 if (flag_realloc_lhs
== 0 && e
->rank
> 0 && e
->shape
== NULL
)
734 ns
= insert_block ();
737 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
739 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
741 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
744 symbol
= symtree
->n
.sym
;
749 symbol
->as
= gfc_get_array_spec ();
750 symbol
->as
->rank
= e
->rank
;
752 if (e
->shape
== NULL
)
754 /* We don't know the shape at compile time, so we use an
756 symbol
->as
->type
= AS_DEFERRED
;
757 symbol
->attr
.allocatable
= 1;
761 symbol
->as
->type
= AS_EXPLICIT
;
762 /* Copy the shape. */
763 for (i
=0; i
<e
->rank
; i
++)
767 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
769 mpz_set_si (p
->value
.integer
, 1);
770 symbol
->as
->lower
[i
] = p
;
772 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
774 mpz_set (q
->value
.integer
, e
->shape
[i
]);
775 symbol
->as
->upper
[i
] = q
;
781 if (e
->ts
.type
== BT_CHARACTER
)
785 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
786 length
= constant_string_length (e
);
788 symbol
->ts
.u
.cl
->length
= length
;
791 symbol
->attr
.allocatable
= 1;
792 symbol
->ts
.u
.cl
->length
= NULL
;
793 symbol
->ts
.deferred
= 1;
798 symbol
->attr
.flavor
= FL_VARIABLE
;
799 symbol
->attr
.referenced
= 1;
800 symbol
->attr
.dimension
= e
->rank
> 0;
801 symbol
->attr
.fe_temp
= 1;
802 gfc_commit_symbol (symbol
);
804 result
= gfc_get_expr ();
805 result
->expr_type
= EXPR_VARIABLE
;
806 result
->ts
= symbol
->ts
;
807 result
->ts
.deferred
= deferred
;
808 result
->rank
= e
->rank
;
809 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
810 result
->symtree
= symtree
;
811 result
->where
= e
->where
;
814 result
->ref
= gfc_get_ref ();
815 result
->ref
->type
= REF_ARRAY
;
816 result
->ref
->u
.ar
.type
= AR_FULL
;
817 result
->ref
->u
.ar
.where
= e
->where
;
818 result
->ref
->u
.ar
.dimen
= e
->rank
;
819 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
820 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
821 if (warn_array_temporaries
)
822 gfc_warning (OPT_Warray_temporaries
,
823 "Creating array temporary at %L", &(e
->where
));
826 /* Generate the new assignment. */
827 n
= XCNEW (gfc_code
);
829 n
->loc
= (*current_code
)->loc
;
830 n
->next
= *changed_statement
;
831 n
->expr1
= gfc_copy_expr (result
);
833 *changed_statement
= n
;
839 /* Warn about function elimination. */
842 do_warn_function_elimination (gfc_expr
*e
)
845 if (e
->expr_type
== EXPR_FUNCTION
846 && !gfc_pure_function (e
, &name
) && !gfc_implicit_pure_function (e
))
849 gfc_warning (OPT_Wfunction_elimination
,
850 "Removing call to impure function %qs at %L", name
,
853 gfc_warning (OPT_Wfunction_elimination
,
854 "Removing call to impure function at %L",
860 /* Callback function for the code walker for doing common function
861 elimination. This builds up the list of functions in the expression
862 and goes through them to detect duplicates, which it then replaces
866 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
867 void *data ATTRIBUTE_UNUSED
)
873 /* Don't do this optimization within OMP workshare or ASSOC lists. */
875 if (in_omp_workshare
|| in_assoc_list
)
881 expr_array
.release ();
883 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
885 /* Walk through all the functions. */
887 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
889 /* Skip if the function has been replaced by a variable already. */
890 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
897 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
900 newvar
= create_var (*ei
, "fcn");
902 if (warn_function_elimination
)
903 do_warn_function_elimination (*ej
);
906 *ej
= gfc_copy_expr (newvar
);
913 /* We did all the necessary walking in this function. */
918 /* Callback function for common function elimination, called from
919 gfc_code_walker. This keeps track of the current code, in order
920 to insert statements as needed. */
923 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
926 inserted_block
= NULL
;
927 changed_statement
= NULL
;
929 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
930 and allocation on assigment are prohibited inside WHERE, and finally
931 masking an expression would lead to wrong-code when replacing
934 b = sum(foo(a) + foo(a))
945 if ((*c
)->op
== EXEC_WHERE
)
955 /* Dummy function for expression call back, for use when we
956 really don't want to do any walking. */
959 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
960 void *data ATTRIBUTE_UNUSED
)
966 /* Dummy function for code callback, for use when we really
967 don't want to do anything. */
969 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
970 int *walk_subtrees ATTRIBUTE_UNUSED
,
971 void *data ATTRIBUTE_UNUSED
)
976 /* Code callback function for converting
983 This is because common function elimination would otherwise place the
984 temporary variables outside the loop. */
987 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
988 void *data ATTRIBUTE_UNUSED
)
991 gfc_code
*c_if1
, *c_if2
, *c_exit
;
993 gfc_expr
*e_not
, *e_cond
;
995 if (co
->op
!= EXEC_DO_WHILE
)
998 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
1003 /* Generate the condition of the if statement, which is .not. the original
1005 e_not
= gfc_get_expr ();
1006 e_not
->ts
= e_cond
->ts
;
1007 e_not
->where
= e_cond
->where
;
1008 e_not
->expr_type
= EXPR_OP
;
1009 e_not
->value
.op
.op
= INTRINSIC_NOT
;
1010 e_not
->value
.op
.op1
= e_cond
;
1012 /* Generate the EXIT statement. */
1013 c_exit
= XCNEW (gfc_code
);
1014 c_exit
->op
= EXEC_EXIT
;
1015 c_exit
->ext
.which_construct
= co
;
1016 c_exit
->loc
= co
->loc
;
1018 /* Generate the IF statement. */
1019 c_if2
= XCNEW (gfc_code
);
1020 c_if2
->op
= EXEC_IF
;
1021 c_if2
->expr1
= e_not
;
1022 c_if2
->next
= c_exit
;
1023 c_if2
->loc
= co
->loc
;
1025 /* ... plus the one to chain it to. */
1026 c_if1
= XCNEW (gfc_code
);
1027 c_if1
->op
= EXEC_IF
;
1028 c_if1
->block
= c_if2
;
1029 c_if1
->loc
= co
->loc
;
1031 /* Make the DO WHILE loop into a DO block by replacing the condition
1032 with a true constant. */
1033 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
1035 /* Hang the generated if statement into the loop body. */
1037 loopblock
= co
->block
->next
;
1038 co
->block
->next
= c_if1
;
1039 c_if1
->next
= loopblock
;
1044 /* Code callback function for converting
1057 because otherwise common function elimination would place the BLOCKs
1058 into the wrong place. */
1061 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1062 void *data ATTRIBUTE_UNUSED
)
1065 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1067 if (co
->op
!= EXEC_IF
)
1070 /* This loop starts out with the first ELSE statement. */
1071 else_stmt
= co
->block
->block
;
1073 while (else_stmt
!= NULL
)
1075 gfc_code
*next_else
;
1077 /* If there is no condition, we're done. */
1078 if (else_stmt
->expr1
== NULL
)
1081 next_else
= else_stmt
->block
;
1083 /* Generate the new IF statement. */
1084 c_if2
= XCNEW (gfc_code
);
1085 c_if2
->op
= EXEC_IF
;
1086 c_if2
->expr1
= else_stmt
->expr1
;
1087 c_if2
->next
= else_stmt
->next
;
1088 c_if2
->loc
= else_stmt
->loc
;
1089 c_if2
->block
= next_else
;
1091 /* ... plus the one to chain it to. */
1092 c_if1
= XCNEW (gfc_code
);
1093 c_if1
->op
= EXEC_IF
;
1094 c_if1
->block
= c_if2
;
1095 c_if1
->loc
= else_stmt
->loc
;
1097 /* Insert the new IF after the ELSE. */
1098 else_stmt
->expr1
= NULL
;
1099 else_stmt
->next
= c_if1
;
1100 else_stmt
->block
= NULL
;
1102 else_stmt
= next_else
;
1104 /* Don't walk subtrees. */
1108 /* Callback function to var_in_expr - return true if expr1 and
1109 expr2 are identical variables. */
1111 var_in_expr_callback (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1114 gfc_expr
*expr1
= (gfc_expr
*) data
;
1115 gfc_expr
*expr2
= *e
;
1117 if (expr2
->expr_type
!= EXPR_VARIABLE
)
1120 return expr1
->symtree
->n
.sym
== expr2
->symtree
->n
.sym
;
1123 /* Return true if expr1 is found in expr2. */
1126 var_in_expr (gfc_expr
*expr1
, gfc_expr
*expr2
)
1128 gcc_assert (expr1
->expr_type
== EXPR_VARIABLE
);
1130 return gfc_expr_walker (&expr2
, var_in_expr_callback
, (void *) expr1
);
1135 struct do_stack
*prev
;
1140 /* Recursively traverse the block of a WRITE or READ statement, and maybe
1141 optimize by replacing do loops with their analog array slices. For
1144 write (*,*) (a(i), i=1,4)
1148 write (*,*) a(1:4:1) . */
1151 traverse_io_block (gfc_code
*code
, bool *has_reached
, gfc_code
*prev
)
1154 gfc_expr
*new_e
, *expr
, *start
;
1156 struct do_stack ds_push
;
1157 int i
, future_rank
= 0;
1158 gfc_iterator
*iters
[GFC_MAX_DIMENSIONS
];
1161 /* Find the first transfer/do statement. */
1162 for (curr
= code
; curr
; curr
= curr
->next
)
1164 if (curr
->op
== EXEC_DO
|| curr
->op
== EXEC_TRANSFER
)
1168 /* Ensure it is the only transfer/do statement because cases like
1170 write (*,*) (a(i), b(i), i=1,4)
1172 cannot be optimized. */
1174 if (!curr
|| curr
->next
)
1177 if (curr
->op
== EXEC_DO
)
1179 if (curr
->ext
.iterator
->var
->ref
)
1181 ds_push
.prev
= stack_top
;
1182 ds_push
.iter
= curr
->ext
.iterator
;
1183 ds_push
.code
= curr
;
1184 stack_top
= &ds_push
;
1185 if (traverse_io_block (curr
->block
->next
, has_reached
, prev
))
1187 if (curr
!= stack_top
->code
&& !*has_reached
)
1189 curr
->block
->next
= NULL
;
1190 gfc_free_statements (curr
);
1193 *has_reached
= true;
1199 gcc_assert (curr
->op
== EXEC_TRANSFER
);
1203 if (!ref
|| ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.codimen
!= 0 || ref
->next
)
1206 /* Find the iterators belonging to each variable and check conditions. */
1207 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1209 if (!ref
->u
.ar
.start
[i
] || ref
->u
.ar
.start
[i
]->ref
1210 || ref
->u
.ar
.dimen_type
[i
] != DIMEN_ELEMENT
)
1213 start
= ref
->u
.ar
.start
[i
];
1214 gfc_simplify_expr (start
, 0);
1215 switch (start
->expr_type
)
1219 /* write (*,*) (a(i), i=a%b,1) not handled yet. */
1223 /* Check for (a(k), i=1,4) or ((a(j, i), i=1,4), j=1,4). */
1224 if (!stack_top
|| !stack_top
->iter
1225 || stack_top
->iter
->var
->symtree
!= start
->symtree
)
1227 /* Check for (a(i,i), i=1,3). */
1231 if (iters
[j
] && iters
[j
]->var
->symtree
== start
->symtree
)
1238 iters
[i
] = stack_top
->iter
;
1239 stack_top
= stack_top
->prev
;
1247 switch (start
->value
.op
.op
)
1249 case INTRINSIC_PLUS
:
1250 case INTRINSIC_TIMES
:
1251 if (start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
)
1252 std::swap (start
->value
.op
.op1
, start
->value
.op
.op2
);
1254 case INTRINSIC_MINUS
:
1255 if ((start
->value
.op
.op1
->expr_type
!= EXPR_VARIABLE
1256 && start
->value
.op
.op2
->expr_type
!= EXPR_CONSTANT
)
1257 || start
->value
.op
.op1
->ref
)
1259 if (!stack_top
|| !stack_top
->iter
1260 || stack_top
->iter
->var
->symtree
1261 != start
->value
.op
.op1
->symtree
)
1263 iters
[i
] = stack_top
->iter
;
1264 stack_top
= stack_top
->prev
;
1276 /* Check for cases like ((a(i, j), i=1, j), j=1, 2). */
1277 for (int i
= 1; i
< ref
->u
.ar
.dimen
; i
++)
1281 gfc_expr
*var
= iters
[i
]->var
;
1282 for (int j
= i
- 1; j
< i
; j
++)
1285 && (var_in_expr (var
, iters
[j
]->start
)
1286 || var_in_expr (var
, iters
[j
]->end
)
1287 || var_in_expr (var
, iters
[j
]->step
)))
1293 /* Create new expr. */
1294 new_e
= gfc_copy_expr (curr
->expr1
);
1295 new_e
->expr_type
= EXPR_VARIABLE
;
1296 new_e
->rank
= future_rank
;
1297 if (curr
->expr1
->shape
)
1298 new_e
->shape
= gfc_get_shape (new_e
->rank
);
1300 /* Assign new starts, ends and strides if necessary. */
1301 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
1305 start
= ref
->u
.ar
.start
[i
];
1306 switch (start
->expr_type
)
1309 gfc_internal_error ("bad expression");
1312 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1313 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1314 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1315 new_e
->ref
->u
.ar
.start
[i
] = gfc_copy_expr (iters
[i
]->start
);
1316 new_e
->ref
->u
.ar
.end
[i
] = gfc_copy_expr (iters
[i
]->end
);
1317 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1320 new_e
->ref
->u
.ar
.dimen_type
[i
] = DIMEN_RANGE
;
1321 new_e
->ref
->u
.ar
.type
= AR_SECTION
;
1322 gfc_free_expr (new_e
->ref
->u
.ar
.start
[i
]);
1323 expr
= gfc_copy_expr (start
);
1324 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->start
);
1325 new_e
->ref
->u
.ar
.start
[i
] = expr
;
1326 gfc_simplify_expr (new_e
->ref
->u
.ar
.start
[i
], 0);
1327 expr
= gfc_copy_expr (start
);
1328 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->end
);
1329 new_e
->ref
->u
.ar
.end
[i
] = expr
;
1330 gfc_simplify_expr (new_e
->ref
->u
.ar
.end
[i
], 0);
1331 switch (start
->value
.op
.op
)
1333 case INTRINSIC_MINUS
:
1334 case INTRINSIC_PLUS
:
1335 new_e
->ref
->u
.ar
.stride
[i
] = gfc_copy_expr (iters
[i
]->step
);
1337 case INTRINSIC_TIMES
:
1338 expr
= gfc_copy_expr (start
);
1339 expr
->value
.op
.op1
= gfc_copy_expr (iters
[i
]->step
);
1340 new_e
->ref
->u
.ar
.stride
[i
] = expr
;
1341 gfc_simplify_expr (new_e
->ref
->u
.ar
.stride
[i
], 0);
1344 gfc_internal_error ("bad op");
1348 gfc_internal_error ("bad expression");
1351 curr
->expr1
= new_e
;
1353 /* Insert modified statement. Check whether the statement needs to be
1354 inserted at the lowest level. */
1355 if (!stack_top
->iter
)
1359 curr
->next
= prev
->next
->next
;
1364 curr
->next
= stack_top
->code
->block
->next
->next
->next
;
1365 stack_top
->code
->block
->next
= curr
;
1369 stack_top
->code
->block
->next
= curr
;
1373 /* Function for the gfc_code_walker. If code is a READ or WRITE statement, it
1374 tries to optimize its block. */
1377 simplify_io_impl_do (gfc_code
**code
, int *walk_subtrees
,
1378 void *data ATTRIBUTE_UNUSED
)
1380 gfc_code
**curr
, *prev
= NULL
;
1381 struct do_stack write
, first
;
1385 || ((*code
)->block
->op
!= EXEC_WRITE
1386 && (*code
)->block
->op
!= EXEC_READ
))
1394 for (curr
= &(*code
)->block
; *curr
; curr
= &(*curr
)->next
)
1396 if ((*curr
)->op
== EXEC_DO
)
1398 first
.prev
= &write
;
1399 first
.iter
= (*curr
)->ext
.iterator
;
1402 traverse_io_block ((*curr
)->block
->next
, &b
, prev
);
1410 /* Optimize a namespace, including all contained namespaces.
1411 flag_frontend_optimize and flag_fronend_loop_interchange are
1412 handled separately. */
1415 optimize_namespace (gfc_namespace
*ns
)
1417 gfc_namespace
*saved_ns
= gfc_current_ns
;
1419 gfc_current_ns
= ns
;
1422 in_assoc_list
= false;
1423 in_omp_workshare
= false;
1425 if (flag_frontend_optimize
)
1427 gfc_code_walker (&ns
->code
, simplify_io_impl_do
, dummy_expr_callback
, NULL
);
1428 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1429 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1430 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1431 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1432 if (flag_inline_matmul_limit
!= 0 || flag_external_blas
)
1438 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1443 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1447 if (flag_external_blas
)
1448 gfc_code_walker (&ns
->code
, call_external_blas
, dummy_expr_callback
,
1451 if (flag_inline_matmul_limit
!= 0)
1452 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1456 if (flag_frontend_loop_interchange
)
1457 gfc_code_walker (&ns
->code
, index_interchange
, dummy_expr_callback
,
1460 /* BLOCKs are handled in the expression walker below. */
1461 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1463 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1464 optimize_namespace (ns
);
1466 gfc_current_ns
= saved_ns
;
1469 /* Handle dependencies for allocatable strings which potentially redefine
1470 themselves in an assignment. */
1473 realloc_strings (gfc_namespace
*ns
)
1476 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1478 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1480 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1481 realloc_strings (ns
);
1487 optimize_reduction (gfc_namespace
*ns
)
1490 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1491 callback_reduction
, NULL
);
1493 /* BLOCKs are handled in the expression walker below. */
1494 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1496 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1497 optimize_reduction (ns
);
1501 /* Replace code like
1504 a = matmul(b,c) ; a = a + d
1505 where the array function is not elemental and not allocatable
1506 and does not depend on the left-hand side.
1510 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1518 if (e
->expr_type
== EXPR_OP
)
1520 switch (e
->value
.op
.op
)
1522 /* Unary operators and exponentiation: Only look at a single
1525 case INTRINSIC_UPLUS
:
1526 case INTRINSIC_UMINUS
:
1527 case INTRINSIC_PARENTHESES
:
1528 case INTRINSIC_POWER
:
1529 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1533 case INTRINSIC_CONCAT
:
1534 /* Do not do string concatenations. */
1538 /* Binary operators. */
1539 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1542 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1548 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1549 && ! (e
->value
.function
.esym
1550 && (e
->value
.function
.esym
->attr
.elemental
1551 || e
->value
.function
.esym
->attr
.allocatable
1552 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1553 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1554 && ! (e
->value
.function
.isym
1555 && (e
->value
.function
.isym
->elemental
1556 || e
->ts
.type
!= c
->expr1
->ts
.type
1557 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1558 && ! gfc_inline_intrinsic_function_p (e
))
1564 /* Insert a new assignment statement after the current one. */
1565 n
= XCNEW (gfc_code
);
1566 n
->op
= EXEC_ASSIGN
;
1571 n
->expr1
= gfc_copy_expr (c
->expr1
);
1572 n
->expr2
= c
->expr2
;
1573 new_expr
= gfc_copy_expr (c
->expr1
);
1581 /* Nothing to optimize. */
1585 /* Remove unneeded TRIMs at the end of expressions. */
1588 remove_trim (gfc_expr
*rhs
)
1596 /* Check for a // b // trim(c). Looping is probably not
1597 necessary because the parser usually generates
1598 (// (// a b ) trim(c) ) , but better safe than sorry. */
1600 while (rhs
->expr_type
== EXPR_OP
1601 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1602 rhs
= rhs
->value
.op
.op2
;
1604 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1605 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1607 strip_function_call (rhs
);
1608 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1616 /* Optimizations for an assignment. */
1619 optimize_assignment (gfc_code
* c
)
1621 gfc_expr
*lhs
, *rhs
;
1626 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1628 /* Optimize a = trim(b) to a = b. */
1631 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1632 if (is_empty_string (rhs
))
1633 rhs
->value
.character
.length
= 0;
1636 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1637 optimize_binop_array_assignment (c
, &rhs
, false);
1641 /* Remove an unneeded function call, modifying the expression.
1642 This replaces the function call with the value of its
1643 first argument. The rest of the argument list is freed. */
1646 strip_function_call (gfc_expr
*e
)
1649 gfc_actual_arglist
*a
;
1651 a
= e
->value
.function
.actual
;
1653 /* We should have at least one argument. */
1654 gcc_assert (a
->expr
!= NULL
);
1658 /* Free the remaining arglist, if any. */
1660 gfc_free_actual_arglist (a
->next
);
1662 /* Graft the argument expression onto the original function. */
1668 /* Optimization of lexical comparison functions. */
1671 optimize_lexical_comparison (gfc_expr
*e
)
1673 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1676 switch (e
->value
.function
.isym
->id
)
1679 return optimize_comparison (e
, INTRINSIC_LE
);
1682 return optimize_comparison (e
, INTRINSIC_GE
);
1685 return optimize_comparison (e
, INTRINSIC_GT
);
1688 return optimize_comparison (e
, INTRINSIC_LT
);
1696 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1697 do CHARACTER because of possible pessimization involving character
1701 combine_array_constructor (gfc_expr
*e
)
1704 gfc_expr
*op1
, *op2
;
1707 gfc_constructor
*c
, *new_c
;
1708 gfc_constructor_base oldbase
, newbase
;
1713 /* Array constructors have rank one. */
1717 /* Don't try to combine association lists, this makes no sense
1718 and leads to an ICE. */
1722 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1723 if (forall_level
> 0)
1726 /* Inside an iterator, things can get hairy; we are likely to create
1727 an invalid temporary variable. */
1728 if (iterator_level
> 0)
1731 op1
= e
->value
.op
.op1
;
1732 op2
= e
->value
.op
.op2
;
1737 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1738 scalar_first
= false;
1739 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1741 scalar_first
= true;
1742 op1
= e
->value
.op
.op2
;
1743 op2
= e
->value
.op
.op1
;
1748 if (op2
->ts
.type
== BT_CHARACTER
)
1751 /* This might be an expanded constructor with very many constant values. If
1752 we perform the operation here, we might end up with a long compile time
1753 and actually longer execution time, so a length bound is in order here.
1754 If the constructor constains something which is not a constant, it did
1755 not come from an expansion, so leave it alone. */
1757 #define CONSTR_LEN_MAX 4
1759 oldbase
= op1
->value
.constructor
;
1763 for (c
= gfc_constructor_first (oldbase
); c
; c
= gfc_constructor_next(c
))
1765 if (c
->expr
->expr_type
!= EXPR_CONSTANT
)
1773 if (all_const
&& n_elem
> CONSTR_LEN_MAX
)
1776 #undef CONSTR_LEN_MAX
1779 e
->expr_type
= EXPR_ARRAY
;
1781 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1783 for (c
= gfc_constructor_first (oldbase
); c
;
1784 c
= gfc_constructor_next (c
))
1786 new_expr
= gfc_get_expr ();
1787 new_expr
->ts
= e
->ts
;
1788 new_expr
->expr_type
= EXPR_OP
;
1789 new_expr
->rank
= c
->expr
->rank
;
1790 new_expr
->where
= c
->expr
->where
;
1791 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1795 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1796 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1800 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1801 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1804 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1805 new_c
->iterator
= c
->iterator
;
1809 gfc_free_expr (op1
);
1810 gfc_free_expr (op2
);
1811 gfc_free_expr (scalar
);
1813 e
->value
.constructor
= newbase
;
1817 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1818 2**k into ishift(1,k) */
1821 optimize_power (gfc_expr
*e
)
1823 gfc_expr
*op1
, *op2
;
1824 gfc_expr
*iand
, *ishft
;
1826 if (e
->ts
.type
!= BT_INTEGER
)
1829 op1
= e
->value
.op
.op1
;
1831 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1834 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1836 gfc_free_expr (op1
);
1838 op2
= e
->value
.op
.op2
;
1843 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1844 "_internal_iand", e
->where
, 2, op2
,
1845 gfc_get_int_expr (e
->ts
.kind
,
1848 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1849 "_internal_ishft", e
->where
, 2, iand
,
1850 gfc_get_int_expr (e
->ts
.kind
,
1853 e
->value
.op
.op
= INTRINSIC_MINUS
;
1854 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1855 e
->value
.op
.op2
= ishft
;
1858 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1860 gfc_free_expr (op1
);
1862 op2
= e
->value
.op
.op2
;
1866 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1867 "_internal_ishft", e
->where
, 2,
1868 gfc_get_int_expr (e
->ts
.kind
,
1875 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1877 op2
= e
->value
.op
.op2
;
1881 gfc_free_expr (op1
);
1882 gfc_free_expr (op2
);
1884 e
->expr_type
= EXPR_CONSTANT
;
1885 e
->value
.op
.op1
= NULL
;
1886 e
->value
.op
.op2
= NULL
;
1887 mpz_init_set_si (e
->value
.integer
, 1);
1888 /* Typespec and location are still OK. */
1895 /* Recursive optimization of operators. */
1898 optimize_op (gfc_expr
*e
)
1902 gfc_intrinsic_op op
= e
->value
.op
.op
;
1906 /* Only use new-style comparisons. */
1909 case INTRINSIC_EQ_OS
:
1913 case INTRINSIC_GE_OS
:
1917 case INTRINSIC_LE_OS
:
1921 case INTRINSIC_NE_OS
:
1925 case INTRINSIC_GT_OS
:
1929 case INTRINSIC_LT_OS
:
1945 changed
= optimize_comparison (e
, op
);
1948 /* Look at array constructors. */
1949 case INTRINSIC_PLUS
:
1950 case INTRINSIC_MINUS
:
1951 case INTRINSIC_TIMES
:
1952 case INTRINSIC_DIVIDE
:
1953 return combine_array_constructor (e
) || changed
;
1955 case INTRINSIC_POWER
:
1956 return optimize_power (e
);
1966 /* Return true if a constant string contains only blanks. */
1969 is_empty_string (gfc_expr
*e
)
1973 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1976 for (i
=0; i
< e
->value
.character
.length
; i
++)
1978 if (e
->value
.character
.string
[i
] != ' ')
1986 /* Insert a call to the intrinsic len_trim. Use a different name for
1987 the symbol tree so we don't run into trouble when the user has
1988 renamed len_trim for some reason. */
1991 get_len_trim_call (gfc_expr
*str
, int kind
)
1994 gfc_actual_arglist
*actual_arglist
, *next
;
1996 fcn
= gfc_get_expr ();
1997 fcn
->expr_type
= EXPR_FUNCTION
;
1998 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1999 actual_arglist
= gfc_get_actual_arglist ();
2000 actual_arglist
->expr
= str
;
2001 next
= gfc_get_actual_arglist ();
2002 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
2003 actual_arglist
->next
= next
;
2005 fcn
->value
.function
.actual
= actual_arglist
;
2006 fcn
->where
= str
->where
;
2007 fcn
->ts
.type
= BT_INTEGER
;
2008 fcn
->ts
.kind
= gfc_charlen_int_kind
;
2010 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
2011 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
2012 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
2013 fcn
->symtree
->n
.sym
->attr
.function
= 1;
2014 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
2015 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
2016 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
2017 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
2022 /* Optimize expressions for equality. */
2025 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
2027 gfc_expr
*op1
, *op2
;
2031 gfc_actual_arglist
*firstarg
, *secondarg
;
2033 if (e
->expr_type
== EXPR_OP
)
2037 op1
= e
->value
.op
.op1
;
2038 op2
= e
->value
.op
.op2
;
2040 else if (e
->expr_type
== EXPR_FUNCTION
)
2042 /* One of the lexical comparison functions. */
2043 firstarg
= e
->value
.function
.actual
;
2044 secondarg
= firstarg
->next
;
2045 op1
= firstarg
->expr
;
2046 op2
= secondarg
->expr
;
2051 /* Strip off unneeded TRIM calls from string comparisons. */
2053 change
= remove_trim (op1
);
2055 if (remove_trim (op2
))
2058 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
2059 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
2060 handles them well). However, there are also cases that need a non-scalar
2061 argument. For example the any intrinsic. See PR 45380. */
2065 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
2067 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2068 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
2070 bool empty_op1
, empty_op2
;
2071 empty_op1
= is_empty_string (op1
);
2072 empty_op2
= is_empty_string (op2
);
2074 if (empty_op1
|| empty_op2
)
2080 /* This can only happen when an error for comparing
2081 characters of different kinds has already been issued. */
2082 if (empty_op1
&& empty_op2
)
2085 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
2086 str
= empty_op1
? op2
: op1
;
2088 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
2092 gfc_free_expr (op1
);
2094 gfc_free_expr (op2
);
2098 e
->value
.op
.op1
= fcn
;
2099 e
->value
.op
.op2
= zero
;
2104 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
2106 if (flag_finite_math_only
2107 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
2108 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
2110 eq
= gfc_dep_compare_expr (op1
, op2
);
2113 /* Replace A // B < A // C with B < C, and A // B < C // B
2115 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
2116 && op1
->expr_type
== EXPR_OP
2117 && op1
->value
.op
.op
== INTRINSIC_CONCAT
2118 && op2
->expr_type
== EXPR_OP
2119 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
2121 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
2122 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
2123 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
2124 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
2126 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
2128 /* Watch out for 'A ' // x vs. 'A' // x. */
2130 if (op1_left
->expr_type
== EXPR_CONSTANT
2131 && op2_left
->expr_type
== EXPR_CONSTANT
2132 && op1_left
->value
.character
.length
2133 != op2_left
->value
.character
.length
)
2141 firstarg
->expr
= op1_right
;
2142 secondarg
->expr
= op2_right
;
2146 e
->value
.op
.op1
= op1_right
;
2147 e
->value
.op
.op2
= op2_right
;
2149 optimize_comparison (e
, op
);
2153 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
2159 firstarg
->expr
= op1_left
;
2160 secondarg
->expr
= op2_left
;
2164 e
->value
.op
.op1
= op1_left
;
2165 e
->value
.op
.op2
= op2_left
;
2168 optimize_comparison (e
, op
);
2175 /* eq can only be -1, 0 or 1 at this point. */
2203 gfc_internal_error ("illegal OP in optimize_comparison");
2207 /* Replace the expression by a constant expression. The typespec
2208 and where remains the way it is. */
2211 e
->expr_type
= EXPR_CONSTANT
;
2212 e
->value
.logical
= result
;
2220 /* Optimize a trim function by replacing it with an equivalent substring
2221 involving a call to len_trim. This only works for expressions where
2222 variables are trimmed. Return true if anything was modified. */
2225 optimize_trim (gfc_expr
*e
)
2230 gfc_ref
**rr
= NULL
;
2232 /* Don't do this optimization within an argument list, because
2233 otherwise aliasing issues may occur. */
2235 if (count_arglist
!= 1)
2238 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
2239 || e
->value
.function
.isym
== NULL
2240 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
2243 a
= e
->value
.function
.actual
->expr
;
2245 if (a
->expr_type
!= EXPR_VARIABLE
)
2248 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
2250 if (a
->symtree
->n
.sym
->attr
.allocatable
)
2253 /* Follow all references to find the correct place to put the newly
2254 created reference. FIXME: Also handle substring references and
2255 array references. Array references cause strange regressions at
2260 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
2262 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
2267 strip_function_call (e
);
2272 /* Create the reference. */
2274 ref
= gfc_get_ref ();
2275 ref
->type
= REF_SUBSTRING
;
2277 /* Set the start of the reference. */
2279 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_charlen_int_kind
, NULL
, 1);
2281 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
2283 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_charlen_int_kind
);
2285 /* Set the end of the reference to the call to len_trim. */
2287 ref
->u
.ss
.end
= fcn
;
2288 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
2293 /* Optimize minloc(b), where b is rank 1 array, into
2294 (/ minloc(b, dim=1) /), and similarly for maxloc,
2295 as the latter forms are expanded inline. */
2298 optimize_minmaxloc (gfc_expr
**e
)
2301 gfc_actual_arglist
*a
;
2305 || fn
->value
.function
.actual
== NULL
2306 || fn
->value
.function
.actual
->expr
== NULL
2307 || fn
->value
.function
.actual
->expr
->rank
!= 1)
2310 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
2311 (*e
)->shape
= fn
->shape
;
2314 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
2316 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
2317 strcpy (name
, fn
->value
.function
.name
);
2318 p
= strstr (name
, "loc0");
2320 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
2321 if (fn
->value
.function
.actual
->next
)
2323 a
= fn
->value
.function
.actual
->next
;
2324 gcc_assert (a
->expr
== NULL
);
2328 a
= gfc_get_actual_arglist ();
2329 fn
->value
.function
.actual
->next
= a
;
2331 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
2333 mpz_set_ui (a
->expr
->value
.integer
, 1);
2336 /* Callback function for code checking that we do not pass a DO variable to an
2337 INTENT(OUT) or INTENT(INOUT) dummy variable. */
2340 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2341 void *data ATTRIBUTE_UNUSED
)
2345 gfc_formal_arglist
*f
;
2346 gfc_actual_arglist
*a
;
2353 /* If the doloop_list grew, we have to truncate it here. */
2355 if ((unsigned) doloop_level
< doloop_list
.length())
2356 doloop_list
.truncate (doloop_level
);
2363 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
2368 loop
.branch_level
= if_level
+ select_level
;
2369 loop
.seen_goto
= false;
2370 doloop_list
.safe_push (loop
);
2373 /* If anything could transfer control away from a suspicious
2374 subscript, make sure to set seen_goto in the current DO loop
2379 case EXEC_ERROR_STOP
:
2385 if (co
->ext
.open
->err
)
2390 if (co
->ext
.close
->err
)
2394 case EXEC_BACKSPACE
:
2399 if (co
->ext
.filepos
->err
)
2404 if (co
->ext
.filepos
->err
)
2410 if (co
->ext
.dt
->err
|| co
->ext
.dt
->end
|| co
->ext
.dt
->eor
)
2415 if (co
->ext
.wait
->err
|| co
->ext
.wait
->end
|| co
->ext
.wait
->eor
)
2416 loop
.seen_goto
= true;
2421 if (co
->resolved_sym
== NULL
)
2424 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
2426 /* Withot a formal arglist, there is only unknown INTENT,
2427 which we don't check for. */
2435 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2443 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2445 if (a
->expr
&& a
->expr
->symtree
2446 && a
->expr
->symtree
->n
.sym
== do_sym
)
2448 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2449 gfc_error_now ("Variable %qs at %L set to undefined "
2450 "value inside loop beginning at %L as "
2451 "INTENT(OUT) argument to subroutine %qs",
2452 do_sym
->name
, &a
->expr
->where
,
2453 &(doloop_list
[i
].c
->loc
),
2454 co
->symtree
->n
.sym
->name
);
2455 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2456 gfc_error_now ("Variable %qs at %L not definable inside "
2457 "loop beginning at %L as INTENT(INOUT) "
2458 "argument to subroutine %qs",
2459 do_sym
->name
, &a
->expr
->where
,
2460 &(doloop_list
[i
].c
->loc
),
2461 co
->symtree
->n
.sym
->name
);
2472 if (seen_goto
&& doloop_level
> 0)
2473 doloop_list
[doloop_level
-1].seen_goto
= true;
2478 /* Callback function to warn about different things within DO loops. */
2481 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2482 void *data ATTRIBUTE_UNUSED
)
2486 if (doloop_list
.length () == 0)
2489 if ((*e
)->expr_type
== EXPR_FUNCTION
)
2492 last
= &doloop_list
.last();
2493 if (last
->seen_goto
&& !warn_do_subscript
)
2496 if ((*e
)->expr_type
== EXPR_VARIABLE
)
2508 /* Callback function - if the expression is the variable in data->sym,
2509 replace it with a constant from data->val. */
2512 callback_insert_index (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2519 if (ex
->expr_type
!= EXPR_VARIABLE
)
2522 d
= (insert_index_t
*) data
;
2523 if (ex
->symtree
->n
.sym
!= d
->sym
)
2526 n
= gfc_get_constant_expr (BT_INTEGER
, ex
->ts
.kind
, &ex
->where
);
2527 mpz_set (n
->value
.integer
, d
->val
);
2534 /* In the expression e, replace occurrences of the variable sym with
2535 val. If this results in a constant expression, return true and
2536 return the value in ret. Return false if the expression already
2537 is a constant. Caller has to clear ret in that case. */
2540 insert_index (gfc_expr
*e
, gfc_symbol
*sym
, mpz_t val
, mpz_t ret
)
2543 insert_index_t data
;
2546 if (e
->expr_type
== EXPR_CONSTANT
)
2549 n
= gfc_copy_expr (e
);
2551 mpz_init_set (data
.val
, val
);
2552 gfc_expr_walker (&n
, callback_insert_index
, (void *) &data
);
2553 gfc_simplify_expr (n
, 0);
2555 if (n
->expr_type
== EXPR_CONSTANT
)
2558 mpz_init_set (ret
, n
->value
.integer
);
2563 mpz_clear (data
.val
);
2569 /* Check array subscripts for possible out-of-bounds accesses in DO
2570 loops with constant bounds. */
2573 do_subscript (gfc_expr
**e
)
2583 /* Constants are already checked. */
2584 if (v
->expr_type
== EXPR_CONSTANT
)
2587 /* Wrong warnings will be generated in an associate list. */
2591 for (ref
= v
->ref
; ref
; ref
= ref
->next
)
2593 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_ELEMENT
)
2596 FOR_EACH_VEC_ELT (doloop_list
, j
, lp
)
2599 mpz_t do_start
, do_step
, do_end
;
2600 bool have_do_start
, have_do_end
;
2601 bool error_not_proven
;
2608 /* If we are within a branch, or a goto or equivalent
2609 was seen in the DO loop before, then we cannot prove that
2610 this expression is actually evaluated. Don't do anything
2611 unless we want to see it all. */
2612 error_not_proven
= lp
->seen_goto
2613 || lp
->branch_level
< if_level
+ select_level
;
2615 if (error_not_proven
&& !warn_do_subscript
)
2618 if (error_not_proven
)
2619 warn
= OPT_Wdo_subscript
;
2623 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2624 if (do_sym
->ts
.type
!= BT_INTEGER
)
2627 /* If we do not know about the stepsize, the loop may be zero trip.
2628 Do not warn in this case. */
2630 if (dl
->ext
.iterator
->step
->expr_type
== EXPR_CONSTANT
)
2631 mpz_init_set (do_step
, dl
->ext
.iterator
->step
->value
.integer
);
2635 if (dl
->ext
.iterator
->start
->expr_type
== EXPR_CONSTANT
)
2637 have_do_start
= true;
2638 mpz_init_set (do_start
, dl
->ext
.iterator
->start
->value
.integer
);
2641 have_do_start
= false;
2644 if (dl
->ext
.iterator
->end
->expr_type
== EXPR_CONSTANT
)
2647 mpz_init_set (do_end
, dl
->ext
.iterator
->end
->value
.integer
);
2650 have_do_end
= false;
2652 if (!have_do_start
&& !have_do_end
)
2655 /* May have to correct the end value if the step does not equal
2657 if (have_do_start
&& have_do_end
&& mpz_cmp_ui (do_step
, 1) != 0)
2663 mpz_sub (diff
, do_end
, do_start
);
2664 mpz_tdiv_r (rem
, diff
, do_step
);
2665 mpz_sub (do_end
, do_end
, rem
);
2670 for (i
= 0; i
< ar
->dimen
; i
++)
2673 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_start
2674 && insert_index (ar
->start
[i
], do_sym
, do_start
, val
))
2676 if (ar
->as
->lower
[i
]
2677 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2678 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2679 gfc_warning (warn
, "Array reference at %L out of bounds "
2680 "(%ld < %ld) in loop beginning at %L",
2681 &ar
->start
[i
]->where
, mpz_get_si (val
),
2682 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2683 &doloop_list
[j
].c
->loc
);
2685 if (ar
->as
->upper
[i
]
2686 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2687 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2688 gfc_warning (warn
, "Array reference at %L out of bounds "
2689 "(%ld > %ld) in loop beginning at %L",
2690 &ar
->start
[i
]->where
, mpz_get_si (val
),
2691 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2692 &doloop_list
[j
].c
->loc
);
2697 if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
&& have_do_end
2698 && insert_index (ar
->start
[i
], do_sym
, do_end
, val
))
2700 if (ar
->as
->lower
[i
]
2701 && ar
->as
->lower
[i
]->expr_type
== EXPR_CONSTANT
2702 && mpz_cmp (val
, ar
->as
->lower
[i
]->value
.integer
) < 0)
2703 gfc_warning (warn
, "Array reference at %L out of bounds "
2704 "(%ld < %ld) in loop beginning at %L",
2705 &ar
->start
[i
]->where
, mpz_get_si (val
),
2706 mpz_get_si (ar
->as
->lower
[i
]->value
.integer
),
2707 &doloop_list
[j
].c
->loc
);
2709 if (ar
->as
->upper
[i
]
2710 && ar
->as
->upper
[i
]->expr_type
== EXPR_CONSTANT
2711 && mpz_cmp (val
, ar
->as
->upper
[i
]->value
.integer
) > 0)
2712 gfc_warning (warn
, "Array reference at %L out of bounds "
2713 "(%ld > %ld) in loop beginning at %L",
2714 &ar
->start
[i
]->where
, mpz_get_si (val
),
2715 mpz_get_si (ar
->as
->upper
[i
]->value
.integer
),
2716 &doloop_list
[j
].c
->loc
);
2726 /* Function for functions checking that we do not pass a DO variable
2727 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2730 do_intent (gfc_expr
**e
)
2732 gfc_formal_arglist
*f
;
2733 gfc_actual_arglist
*a
;
2740 if (expr
->expr_type
!= EXPR_FUNCTION
)
2743 /* Intrinsic functions don't modify their arguments. */
2745 if (expr
->value
.function
.isym
)
2748 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2750 /* Without a formal arglist, there is only unknown INTENT,
2751 which we don't check for. */
2755 a
= expr
->value
.function
.actual
;
2759 FOR_EACH_VEC_ELT (doloop_list
, i
, lp
)
2766 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2768 if (a
->expr
&& a
->expr
->symtree
2769 && a
->expr
->symtree
->n
.sym
== do_sym
)
2771 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2772 gfc_error_now ("Variable %qs at %L set to undefined value "
2773 "inside loop beginning at %L as INTENT(OUT) "
2774 "argument to function %qs", do_sym
->name
,
2775 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2776 expr
->symtree
->n
.sym
->name
);
2777 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2778 gfc_error_now ("Variable %qs at %L not definable inside loop"
2779 " beginning at %L as INTENT(INOUT) argument to"
2780 " function %qs", do_sym
->name
,
2781 &a
->expr
->where
, &doloop_list
[i
].c
->loc
,
2782 expr
->symtree
->n
.sym
->name
);
2793 doloop_warn (gfc_namespace
*ns
)
2795 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2798 /* This selction deals with inlining calls to MATMUL. */
2800 /* Replace calls to matmul outside of straight assignments with a temporary
2801 variable so that later inlining will work. */
2804 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2808 bool *found
= (bool *) data
;
2812 if (e
->expr_type
!= EXPR_FUNCTION
2813 || e
->value
.function
.isym
== NULL
2814 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2817 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2818 || in_where
|| in_assoc_list
)
2821 /* Check if this is already in the form c = matmul(a,b). */
2823 if ((*current_code
)->expr2
== e
)
2826 n
= create_var (e
, "matmul");
2828 /* If create_var is unable to create a variable (for example if
2829 -fno-realloc-lhs is in force with a variable that does not have bounds
2830 known at compile-time), just return. */
2840 /* Set current_code and associated variables so that matmul_to_var_expr can
2844 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2845 void *data ATTRIBUTE_UNUSED
)
2847 if (current_code
!= c
)
2850 inserted_block
= NULL
;
2851 changed_statement
= NULL
;
2858 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2859 for a and b if there is a dependency between the arguments and the
2860 result variable or if a or b are the result of calculations that cannot
2861 be handled by the inliner. */
2864 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2865 void *data ATTRIBUTE_UNUSED
)
2867 gfc_expr
*expr1
, *expr2
;
2869 gfc_actual_arglist
*a
, *b
;
2871 gfc_expr
*matrix_a
, *matrix_b
;
2872 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2876 if (co
->op
!= EXEC_ASSIGN
)
2879 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2883 /* This has some duplication with inline_matmul_assign. This
2884 is because the creation of temporary variables could still fail,
2885 and inline_matmul_assign still needs to be able to handle these
2890 if (expr2
->expr_type
!= EXPR_FUNCTION
2891 || expr2
->value
.function
.isym
== NULL
2892 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2896 a
= expr2
->value
.function
.actual
;
2897 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2898 if (matrix_a
!= NULL
)
2900 if (matrix_a
->expr_type
== EXPR_VARIABLE
2901 && (gfc_check_dependency (matrix_a
, expr1
, true)
2902 || has_dimen_vector_ref (matrix_a
)))
2910 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2911 if (matrix_b
!= NULL
)
2913 if (matrix_b
->expr_type
== EXPR_VARIABLE
2914 && (gfc_check_dependency (matrix_b
, expr1
, true)
2915 || has_dimen_vector_ref (matrix_b
)))
2921 if (!a_tmp
&& !b_tmp
)
2925 inserted_block
= NULL
;
2926 changed_statement
= NULL
;
2930 at
= create_var (a
->expr
,"mma");
2937 bt
= create_var (b
->expr
,"mmb");
2944 /* Auxiliary function to build and simplify an array inquiry function.
2945 dim is zero-based. */
2948 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
, int okind
= 0)
2951 gfc_expr
*dim_arg
, *kind
;
2957 case GFC_ISYM_LBOUND
:
2958 name
= "_gfortran_lbound";
2961 case GFC_ISYM_UBOUND
:
2962 name
= "_gfortran_ubound";
2966 name
= "_gfortran_size";
2973 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2975 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2978 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2979 gfc_index_integer_kind
);
2981 ec
= gfc_copy_expr (e
);
2983 /* No bounds checking, this will be done before the loops if -fcheck=bounds
2985 ec
->no_bounds_check
= 1;
2986 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2988 gfc_simplify_expr (fcn
, 0);
2989 fcn
->no_bounds_check
= 1;
2993 /* Builds a logical expression. */
2996 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3001 ts
.type
= BT_LOGICAL
;
3002 ts
.kind
= gfc_default_logical_kind
;
3003 res
= gfc_get_expr ();
3004 res
->where
= e1
->where
;
3005 res
->expr_type
= EXPR_OP
;
3006 res
->value
.op
.op
= op
;
3007 res
->value
.op
.op1
= e1
;
3008 res
->value
.op
.op2
= e2
;
3015 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
3016 compatible typespecs. */
3019 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
3023 res
= gfc_get_expr ();
3025 res
->where
= e1
->where
;
3026 res
->expr_type
= EXPR_OP
;
3027 res
->value
.op
.op
= op
;
3028 res
->value
.op
.op1
= e1
;
3029 res
->value
.op
.op2
= e2
;
3030 gfc_simplify_expr (res
, 0);
3034 /* Generate the IF statement for a runtime check if we want to do inlining or
3035 not - putting in the code for both branches and putting it into the syntax
3036 tree is the caller's responsibility. For fixed array sizes, this should be
3037 removed by DCE. Only called for rank-two matrices A and B. */
3040 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, int limit
)
3042 gfc_expr
*inline_limit
;
3043 gfc_code
*if_1
, *if_2
, *else_2
;
3044 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
3048 /* Calculation is done in real to avoid integer overflow. */
3050 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
3052 mpfr_set_si (inline_limit
->value
.real
, limit
, GFC_RND_MODE
);
3053 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
3056 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3057 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3058 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3062 ts
.kind
= gfc_default_real_kind
;
3063 gfc_convert_type_warn (a1
, &ts
, 2, 0);
3064 gfc_convert_type_warn (a2
, &ts
, 2, 0);
3065 gfc_convert_type_warn (b2
, &ts
, 2, 0);
3067 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
3068 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
3070 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
3071 gfc_simplify_expr (cond
, 0);
3073 else_2
= XCNEW (gfc_code
);
3074 else_2
->op
= EXEC_IF
;
3075 else_2
->loc
= a
->where
;
3077 if_2
= XCNEW (gfc_code
);
3080 if_2
->loc
= a
->where
;
3081 if_2
->block
= else_2
;
3083 if_1
= XCNEW (gfc_code
);
3086 if_1
->loc
= a
->where
;
3092 /* Insert code to issue a runtime error if the expressions are not equal. */
3095 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
3098 gfc_code
*if_1
, *if_2
;
3100 gfc_actual_arglist
*a1
, *a2
, *a3
;
3102 gcc_assert (e1
->where
.lb
);
3103 /* Build the call to runtime_error. */
3104 c
= XCNEW (gfc_code
);
3108 /* Get a null-terminated message string. */
3110 a1
= gfc_get_actual_arglist ();
3111 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
3112 msg
, strlen(msg
)+1);
3115 /* Pass the value of the first expression. */
3116 a2
= gfc_get_actual_arglist ();
3117 a2
->expr
= gfc_copy_expr (e1
);
3120 /* Pass the value of the second expression. */
3121 a3
= gfc_get_actual_arglist ();
3122 a3
->expr
= gfc_copy_expr (e2
);
3125 gfc_check_fe_runtime_error (c
->ext
.actual
);
3126 gfc_resolve_fe_runtime_error (c
);
3128 if_2
= XCNEW (gfc_code
);
3130 if_2
->loc
= e1
->where
;
3133 if_1
= XCNEW (gfc_code
);
3136 if_1
->loc
= e1
->where
;
3138 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
3139 gfc_simplify_expr (cond
, 0);
3145 /* Handle matrix reallocation. Caller is responsible to insert into
3148 For the two-dimensional case, build
3150 if (allocated(c)) then
3151 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
3153 allocate (c(size(a,1), size(b,2)))
3156 allocate (c(size(a,1),size(b,2)))
3159 and for the other cases correspondingly.
3163 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
3164 enum matrix_case m_case
)
3167 gfc_expr
*allocated
, *alloc_expr
;
3168 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
3169 gfc_code
*else_alloc
;
3170 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
3172 gfc_expr
*cond
, *ne1
, *ne2
;
3174 if (warn_realloc_lhs
)
3175 gfc_warning (OPT_Wrealloc_lhs
,
3176 "Code for reallocating the allocatable array at %L will "
3177 "be added", &c
->where
);
3179 alloc_expr
= gfc_copy_expr (c
);
3181 ar
= gfc_find_array_ref (alloc_expr
);
3182 gcc_assert (ar
&& ar
->type
== AR_FULL
);
3184 /* c comes in as a full ref. Change it into a copy and make it into an
3185 element ref so it has the right form for for ALLOCATE. In the same
3186 switch statement, also generate the size comparison for the secod IF
3189 ar
->type
= AR_ELEMENT
;
3194 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3195 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3196 ne1
= build_logical_expr (INTRINSIC_NE
,
3197 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3198 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3199 ne2
= build_logical_expr (INTRINSIC_NE
,
3200 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3201 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3202 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3206 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3207 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3209 ne1
= build_logical_expr (INTRINSIC_NE
,
3210 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3211 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
3212 ne2
= build_logical_expr (INTRINSIC_NE
,
3213 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3214 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3215 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3220 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3221 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3223 ne1
= build_logical_expr (INTRINSIC_NE
,
3224 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3225 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3226 ne2
= build_logical_expr (INTRINSIC_NE
,
3227 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3228 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3229 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3233 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
3234 cond
= build_logical_expr (INTRINSIC_NE
,
3235 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3236 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3240 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
3241 cond
= build_logical_expr (INTRINSIC_NE
,
3242 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3243 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
3247 /* This can only happen for BLAS, we do not handle that case in
3249 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
3250 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
3252 ne1
= build_logical_expr (INTRINSIC_NE
,
3253 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
3254 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
3255 ne2
= build_logical_expr (INTRINSIC_NE
,
3256 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
3257 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
3259 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
3267 gfc_simplify_expr (cond
, 0);
3269 /* We need two identical allocate statements in two
3270 branches of the IF statement. */
3272 allocate1
= XCNEW (gfc_code
);
3273 allocate1
->op
= EXEC_ALLOCATE
;
3274 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
3275 allocate1
->loc
= c
->where
;
3276 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
3278 allocate_else
= XCNEW (gfc_code
);
3279 allocate_else
->op
= EXEC_ALLOCATE
;
3280 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
3281 allocate_else
->loc
= c
->where
;
3282 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
3284 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
3285 "_gfortran_allocated", c
->where
,
3286 1, gfc_copy_expr (c
));
3288 deallocate
= XCNEW (gfc_code
);
3289 deallocate
->op
= EXEC_DEALLOCATE
;
3290 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
3291 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
3292 deallocate
->next
= allocate1
;
3293 deallocate
->loc
= c
->where
;
3295 if_size_2
= XCNEW (gfc_code
);
3296 if_size_2
->op
= EXEC_IF
;
3297 if_size_2
->expr1
= cond
;
3298 if_size_2
->loc
= c
->where
;
3299 if_size_2
->next
= deallocate
;
3301 if_size_1
= XCNEW (gfc_code
);
3302 if_size_1
->op
= EXEC_IF
;
3303 if_size_1
->block
= if_size_2
;
3304 if_size_1
->loc
= c
->where
;
3306 else_alloc
= XCNEW (gfc_code
);
3307 else_alloc
->op
= EXEC_IF
;
3308 else_alloc
->loc
= c
->where
;
3309 else_alloc
->next
= allocate_else
;
3311 if_alloc_2
= XCNEW (gfc_code
);
3312 if_alloc_2
->op
= EXEC_IF
;
3313 if_alloc_2
->expr1
= allocated
;
3314 if_alloc_2
->loc
= c
->where
;
3315 if_alloc_2
->next
= if_size_1
;
3316 if_alloc_2
->block
= else_alloc
;
3318 if_alloc_1
= XCNEW (gfc_code
);
3319 if_alloc_1
->op
= EXEC_IF
;
3320 if_alloc_1
->block
= if_alloc_2
;
3321 if_alloc_1
->loc
= c
->where
;
3326 /* Callback function for has_function_or_op. */
3329 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
3330 void *data ATTRIBUTE_UNUSED
)
3335 return (*e
)->expr_type
== EXPR_FUNCTION
3336 || (*e
)->expr_type
== EXPR_OP
;
3339 /* Returns true if the expression contains a function. */
3342 has_function_or_op (gfc_expr
**e
)
3347 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
3350 /* Freeze (assign to a temporary variable) a single expression. */
3353 freeze_expr (gfc_expr
**ep
)
3356 if (has_function_or_op (ep
))
3358 ne
= create_var (*ep
, "freeze");
3363 /* Go through an expression's references and assign them to temporary
3364 variables if they contain functions. This is usually done prior to
3365 front-end scalarization to avoid multiple invocations of functions. */
3368 freeze_references (gfc_expr
*e
)
3374 for (r
=e
->ref
; r
; r
=r
->next
)
3376 if (r
->type
== REF_SUBSTRING
)
3378 if (r
->u
.ss
.start
!= NULL
)
3379 freeze_expr (&r
->u
.ss
.start
);
3381 if (r
->u
.ss
.end
!= NULL
)
3382 freeze_expr (&r
->u
.ss
.end
);
3384 else if (r
->type
== REF_ARRAY
)
3393 for (i
=0; i
<ar
->dimen
; i
++)
3395 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
3397 freeze_expr (&ar
->start
[i
]);
3398 freeze_expr (&ar
->end
[i
]);
3399 freeze_expr (&ar
->stride
[i
]);
3401 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
3403 freeze_expr (&ar
->start
[i
]);
3409 for (i
=0; i
<ar
->dimen
; i
++)
3410 freeze_expr (&ar
->start
[i
]);
3420 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
3423 convert_to_index_kind (gfc_expr
*e
)
3427 gcc_assert (e
!= NULL
);
3429 res
= gfc_copy_expr (e
);
3431 gcc_assert (e
->ts
.type
== BT_INTEGER
);
3433 if (res
->ts
.kind
!= gfc_index_integer_kind
)
3437 ts
.type
= BT_INTEGER
;
3438 ts
.kind
= gfc_index_integer_kind
;
3440 gfc_convert_type_warn (e
, &ts
, 2, 0);
3446 /* Function to create a DO loop including creation of the
3447 iteration variable. gfc_expr are copied.*/
3450 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
3451 gfc_namespace
*ns
, char *vname
)
3454 char name
[GFC_MAX_SYMBOL_LEN
+1];
3455 gfc_symtree
*symtree
;
3460 /* Create an expression for the iteration variable. */
3462 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
3464 sprintf (name
, "__var_%d_do", var_num
++);
3467 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
3470 /* Create the loop variable. */
3472 symbol
= symtree
->n
.sym
;
3473 symbol
->ts
.type
= BT_INTEGER
;
3474 symbol
->ts
.kind
= gfc_index_integer_kind
;
3475 symbol
->attr
.flavor
= FL_VARIABLE
;
3476 symbol
->attr
.referenced
= 1;
3477 symbol
->attr
.dimension
= 0;
3478 symbol
->attr
.fe_temp
= 1;
3479 gfc_commit_symbol (symbol
);
3481 i
= gfc_get_expr ();
3482 i
->expr_type
= EXPR_VARIABLE
;
3486 i
->symtree
= symtree
;
3488 /* ... and the nested DO statements. */
3489 n
= XCNEW (gfc_code
);
3492 n
->ext
.iterator
= gfc_get_iterator ();
3493 n
->ext
.iterator
->var
= i
;
3494 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
3495 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
3497 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
3499 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
3502 n2
= XCNEW (gfc_code
);
3510 /* Get the upper bound of the DO loops for matmul along a dimension. This
3514 get_size_m1 (gfc_expr
*e
, int dimen
)
3519 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
3521 res
= gfc_get_constant_expr (BT_INTEGER
,
3522 gfc_index_integer_kind
, &e
->where
);
3523 mpz_sub_ui (res
->value
.integer
, size
, 1);
3528 res
= get_operand (INTRINSIC_MINUS
,
3529 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
3530 gfc_get_int_expr (gfc_index_integer_kind
,
3532 gfc_simplify_expr (res
, 0);
3538 /* Function to return a scalarized expression. It is assumed that indices are
3539 zero based to make generation of DO loops easier. A zero as index will
3540 access the first element along a dimension. Single element references will
3541 be skipped. A NULL as an expression will be replaced by a full reference.
3542 This assumes that the index loops have gfc_index_integer_kind, and that all
3543 references have been frozen. */
3546 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
3555 e
= gfc_copy_expr(e_in
);
3559 ar
= gfc_find_array_ref (e
);
3561 /* We scalarize count_index variables, reducing the rank by count_index. */
3563 e
->rank
= rank
- count_index
;
3565 was_fullref
= ar
->type
== AR_FULL
;
3568 ar
->type
= AR_ELEMENT
;
3570 ar
->type
= AR_SECTION
;
3572 /* Loop over the indices. For each index, create the expression
3573 index * stride + lbound(e, dim). */
3576 for (i
=0; i
< ar
->dimen
; i
++)
3578 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
3580 if (index
[i_index
] != NULL
)
3582 gfc_expr
*lbound
, *nindex
;
3585 loopvar
= gfc_copy_expr (index
[i_index
]);
3591 tmp
= gfc_copy_expr(ar
->stride
[i
]);
3592 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
3596 ts
.type
= BT_INTEGER
;
3597 ts
.kind
= gfc_index_integer_kind
;
3598 gfc_convert_type (tmp
, &ts
, 2);
3600 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
3605 /* Calculate the lower bound of the expression. */
3608 lbound
= gfc_copy_expr (ar
->start
[i
]);
3609 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
3613 ts
.type
= BT_INTEGER
;
3614 ts
.kind
= gfc_index_integer_kind
;
3615 gfc_convert_type (lbound
, &ts
, 2);
3624 lbound_e
= gfc_copy_expr (e_in
);
3626 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
3627 if (ref
->type
== REF_ARRAY
3628 && (ref
->u
.ar
.type
== AR_FULL
3629 || ref
->u
.ar
.type
== AR_SECTION
))
3634 gfc_free_ref_list (ref
->next
);
3640 /* Look at full individual sections, like a(:). The first index
3641 is the lbound of a full ref. */
3648 /* For assumed size, we need to keep around the final
3649 reference in order not to get an error on resolution
3650 below, and we cannot use AR_FULL. */
3652 if (ar
->as
->type
== AS_ASSUMED_SIZE
)
3654 ar
->type
= AR_SECTION
;
3663 for (j
= 0; j
< to
; j
++)
3665 gfc_free_expr (ar
->start
[j
]);
3666 ar
->start
[j
] = NULL
;
3667 gfc_free_expr (ar
->end
[j
]);
3669 gfc_free_expr (ar
->stride
[j
]);
3670 ar
->stride
[j
] = NULL
;
3673 /* We have to get rid of the shape, if there is one. Do
3674 so by freeing it and calling gfc_resolve to rebuild
3675 it, if necessary. */
3677 if (lbound_e
->shape
)
3678 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
3680 lbound_e
->rank
= ar
->dimen
;
3681 gfc_resolve_expr (lbound_e
);
3683 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
3685 gfc_free_expr (lbound_e
);
3688 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
3690 gfc_free_expr (ar
->start
[i
]);
3691 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
3693 gfc_free_expr (ar
->end
[i
]);
3695 gfc_free_expr (ar
->stride
[i
]);
3696 ar
->stride
[i
] = NULL
;
3697 gfc_simplify_expr (ar
->start
[i
], 0);
3699 else if (was_fullref
)
3701 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
3707 /* Bounds checking will be done before the loops if -fcheck=bounds
3709 e
->no_bounds_check
= 1;
3713 /* Helper function to check for a dimen vector as subscript. */
3716 has_dimen_vector_ref (gfc_expr
*e
)
3721 ar
= gfc_find_array_ref (e
);
3723 if (ar
->type
== AR_FULL
)
3726 for (i
=0; i
<ar
->dimen
; i
++)
3727 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3733 /* If handed an expression of the form
3737 check if A can be handled by matmul and return if there is an uneven number
3738 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3739 otherwise. The caller has to check for the correct rank. */
3742 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3749 if (e
->expr_type
== EXPR_VARIABLE
)
3751 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3754 else if (e
->expr_type
== EXPR_FUNCTION
)
3756 if (e
->value
.function
.isym
== NULL
)
3759 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3761 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3762 *transpose
= !*transpose
;
3768 e
= e
->value
.function
.actual
->expr
;
3775 /* Macros for unified error messages. */
3777 #define B_ERROR(n) _("Incorrect extent in argument B in MATMUL intrinsic in " \
3778 "dimension " #n ": is %ld, should be %ld")
3780 #define C_ERROR(n) _("Array bound mismatch for dimension " #n " of array " \
3784 /* Inline assignments of the form c = matmul(a,b).
3785 Handle only the cases currently where b and c are rank-two arrays.
3787 This basically translates the code to
3793 do k=0, size(a, 2)-1
3794 do i=0, size(a, 1)-1
3795 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3796 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3797 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3798 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3807 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3808 void *data ATTRIBUTE_UNUSED
)
3811 gfc_expr
*expr1
, *expr2
;
3812 gfc_expr
*matrix_a
, *matrix_b
;
3813 gfc_actual_arglist
*a
, *b
;
3814 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3816 gfc_expr
*u1
, *u2
, *u3
;
3818 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3820 gfc_expr
*var_1
, *var_2
, *var_3
;
3823 gfc_intrinsic_op op_times
, op_plus
;
3824 enum matrix_case m_case
;
3826 gfc_code
*if_limit
= NULL
;
3827 gfc_code
**next_code_point
;
3828 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3831 if (co
->op
!= EXEC_ASSIGN
)
3834 if (in_where
|| in_assoc_list
)
3837 /* The BLOCKS generated for the temporary variables and FORALL don't
3839 if (forall_level
> 0)
3842 /* For now don't do anything in OpenMP workshare, it confuses
3843 its translation, which expects only the allowed statements in there.
3844 We should figure out how to parallelize this eventually. */
3845 if (in_omp_workshare
)
3850 if (expr2
->expr_type
!= EXPR_FUNCTION
3851 || expr2
->value
.function
.isym
== NULL
3852 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3856 inserted_block
= NULL
;
3857 changed_statement
= NULL
;
3859 a
= expr2
->value
.function
.actual
;
3860 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3861 if (matrix_a
== NULL
)
3865 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3866 if (matrix_b
== NULL
)
3869 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3870 || has_dimen_vector_ref (matrix_b
))
3873 /* We do not handle data dependencies yet. */
3874 if (gfc_check_dependency (expr1
, matrix_a
, true)
3875 || gfc_check_dependency (expr1
, matrix_b
, true))
3879 if (matrix_a
->rank
== 2)
3883 if (matrix_b
->rank
== 2 && !transpose_b
)
3888 if (matrix_b
->rank
== 1)
3890 else /* matrix_b->rank == 2 */
3899 else /* matrix_a->rank == 1 */
3901 if (matrix_b
->rank
== 2)
3911 ns
= insert_block ();
3913 /* Assign the type of the zero expression for initializing the resulting
3914 array, and the expression (+ and * for real, integer and complex;
3915 .and. and .or for logical. */
3917 switch(expr1
->ts
.type
)
3920 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3921 op_times
= INTRINSIC_TIMES
;
3922 op_plus
= INTRINSIC_PLUS
;
3926 op_times
= INTRINSIC_AND
;
3927 op_plus
= INTRINSIC_OR
;
3928 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3932 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3934 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3935 op_times
= INTRINSIC_TIMES
;
3936 op_plus
= INTRINSIC_PLUS
;
3940 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3942 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3943 op_times
= INTRINSIC_TIMES
;
3944 op_plus
= INTRINSIC_PLUS
;
3952 current_code
= &ns
->code
;
3954 /* Freeze the references, keeping track of how many temporary variables were
3957 freeze_references (matrix_a
);
3958 freeze_references (matrix_b
);
3959 freeze_references (expr1
);
3962 next_code_point
= current_code
;
3965 next_code_point
= &ns
->code
;
3966 for (i
=0; i
<n_vars
; i
++)
3967 next_code_point
= &(*next_code_point
)->next
;
3970 /* Take care of the inline flag. If the limit check evaluates to a
3971 constant, dead code elimination will eliminate the unneeded branch. */
3973 if (flag_inline_matmul_limit
> 0 && matrix_a
->rank
== 2
3974 && matrix_b
->rank
== 2)
3976 if_limit
= inline_limit_check (matrix_a
, matrix_b
,
3977 flag_inline_matmul_limit
);
3979 /* Insert the original statement into the else branch. */
3980 if_limit
->block
->block
->next
= co
;
3983 /* ... and the new ones go into the original one. */
3984 *next_code_point
= if_limit
;
3985 next_code_point
= &if_limit
->block
->next
;
3988 zero_e
->no_bounds_check
= 1;
3990 assign_zero
= XCNEW (gfc_code
);
3991 assign_zero
->op
= EXEC_ASSIGN
;
3992 assign_zero
->loc
= co
->loc
;
3993 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3994 assign_zero
->expr1
->no_bounds_check
= 1;
3995 assign_zero
->expr2
= zero_e
;
3997 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
3999 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4002 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
4008 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4009 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4010 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4011 *next_code_point
= test
;
4012 next_code_point
= &test
->next
;
4016 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4017 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4018 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4019 *next_code_point
= test
;
4020 next_code_point
= &test
->next
;
4026 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4027 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4028 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4029 *next_code_point
= test
;
4030 next_code_point
= &test
->next
;
4034 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4035 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4036 test
= runtime_error_ne (c1
, b2
, C_ERROR(1));
4037 *next_code_point
= test
;
4038 next_code_point
= &test
->next
;
4044 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4045 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4046 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4047 *next_code_point
= test
;
4048 next_code_point
= &test
->next
;
4052 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4053 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4054 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4055 *next_code_point
= test
;
4056 next_code_point
= &test
->next
;
4058 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4059 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4060 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4061 *next_code_point
= test
;
4062 next_code_point
= &test
->next
;
4068 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4069 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4070 /* matrix_b is transposed, hence dimension 1 for the error message. */
4071 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4072 *next_code_point
= test
;
4073 next_code_point
= &test
->next
;
4077 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4078 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4079 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4080 *next_code_point
= test
;
4081 next_code_point
= &test
->next
;
4083 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4084 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4085 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4086 *next_code_point
= test
;
4087 next_code_point
= &test
->next
;
4093 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4094 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4095 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4096 *next_code_point
= test
;
4097 next_code_point
= &test
->next
;
4101 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4102 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4103 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4104 *next_code_point
= test
;
4105 next_code_point
= &test
->next
;
4107 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4108 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4109 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4110 *next_code_point
= test
;
4111 next_code_point
= &test
->next
;
4120 /* Handle the reallocation, if needed. */
4124 gfc_code
*lhs_alloc
;
4126 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4128 *next_code_point
= lhs_alloc
;
4129 next_code_point
= &lhs_alloc
->next
;
4133 *next_code_point
= assign_zero
;
4135 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
4137 assign_matmul
= XCNEW (gfc_code
);
4138 assign_matmul
->op
= EXEC_ASSIGN
;
4139 assign_matmul
->loc
= co
->loc
;
4141 /* Get the bounds for the loops, create them and create the scalarized
4148 u1
= get_size_m1 (matrix_b
, 2);
4149 u2
= get_size_m1 (matrix_a
, 2);
4150 u3
= get_size_m1 (matrix_a
, 1);
4152 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4153 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4154 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4156 do_1
->block
->next
= do_2
;
4157 do_2
->block
->next
= do_3
;
4158 do_3
->block
->next
= assign_matmul
;
4160 var_1
= do_1
->ext
.iterator
->var
;
4161 var_2
= do_2
->ext
.iterator
->var
;
4162 var_3
= do_3
->ext
.iterator
->var
;
4166 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4170 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4174 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4180 u1
= get_size_m1 (matrix_b
, 1);
4181 u2
= get_size_m1 (matrix_a
, 2);
4182 u3
= get_size_m1 (matrix_a
, 1);
4184 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4185 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4186 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4188 do_1
->block
->next
= do_2
;
4189 do_2
->block
->next
= do_3
;
4190 do_3
->block
->next
= assign_matmul
;
4192 var_1
= do_1
->ext
.iterator
->var
;
4193 var_2
= do_2
->ext
.iterator
->var
;
4194 var_3
= do_3
->ext
.iterator
->var
;
4198 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4202 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4206 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4212 u1
= get_size_m1 (matrix_a
, 2);
4213 u2
= get_size_m1 (matrix_b
, 2);
4214 u3
= get_size_m1 (matrix_a
, 1);
4216 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4217 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4218 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
4220 do_1
->block
->next
= do_2
;
4221 do_2
->block
->next
= do_3
;
4222 do_3
->block
->next
= assign_matmul
;
4224 var_1
= do_1
->ext
.iterator
->var
;
4225 var_2
= do_2
->ext
.iterator
->var
;
4226 var_3
= do_3
->ext
.iterator
->var
;
4230 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
4234 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4238 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4243 u1
= get_size_m1 (matrix_b
, 1);
4244 u2
= get_size_m1 (matrix_a
, 1);
4246 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4247 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4249 do_1
->block
->next
= do_2
;
4250 do_2
->block
->next
= assign_matmul
;
4252 var_1
= do_1
->ext
.iterator
->var
;
4253 var_2
= do_2
->ext
.iterator
->var
;
4256 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4260 ascalar
= scalarized_expr (matrix_a
, list
, 2);
4263 bscalar
= scalarized_expr (matrix_b
, list
, 1);
4268 u1
= get_size_m1 (matrix_b
, 2);
4269 u2
= get_size_m1 (matrix_a
, 1);
4271 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
4272 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
4274 do_1
->block
->next
= do_2
;
4275 do_2
->block
->next
= assign_matmul
;
4277 var_1
= do_1
->ext
.iterator
->var
;
4278 var_2
= do_2
->ext
.iterator
->var
;
4281 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
4284 ascalar
= scalarized_expr (matrix_a
, list
, 1);
4288 bscalar
= scalarized_expr (matrix_b
, list
, 2);
4296 /* Build the conjg call around the variables. Set the typespec manually
4297 because gfc_build_intrinsic_call sometimes gets this wrong. */
4302 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4303 matrix_a
->where
, 1, ascalar
);
4311 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
4312 matrix_b
->where
, 1, bscalar
);
4315 /* First loop comes after the zero assignment. */
4316 assign_zero
->next
= do_1
;
4318 /* Build the assignment expression in the loop. */
4319 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
4321 mult
= get_operand (op_times
, ascalar
, bscalar
);
4322 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
4324 /* If we don't want to keep the original statement around in
4325 the else branch, we can free it. */
4327 if (if_limit
== NULL
)
4328 gfc_free_statements(co
);
4332 gfc_free_expr (zero
);
4337 /* Change matmul function calls in the form of
4341 to the corresponding call to a BLAS routine, if applicable. */
4344 call_external_blas (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4345 void *data ATTRIBUTE_UNUSED
)
4347 gfc_code
*co
, *co_next
;
4348 gfc_expr
*expr1
, *expr2
;
4349 gfc_expr
*matrix_a
, *matrix_b
;
4350 gfc_code
*if_limit
= NULL
;
4351 gfc_actual_arglist
*a
, *b
;
4352 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
4354 const char *blas_name
;
4355 const char *transa
, *transb
;
4356 gfc_expr
*c1
, *c2
, *b1
;
4357 gfc_actual_arglist
*actual
, *next
;
4360 enum matrix_case m_case
;
4362 gfc_code
**next_code_point
;
4364 /* Many of the tests for inline matmul also apply here. */
4368 if (co
->op
!= EXEC_ASSIGN
)
4371 if (in_where
|| in_assoc_list
)
4374 /* The BLOCKS generated for the temporary variables and FORALL don't
4376 if (forall_level
> 0)
4379 /* For now don't do anything in OpenMP workshare, it confuses
4380 its translation, which expects only the allowed statements in there. */
4382 if (in_omp_workshare
)
4387 if (expr2
->expr_type
!= EXPR_FUNCTION
4388 || expr2
->value
.function
.isym
== NULL
4389 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
4392 type
= expr2
->ts
.type
;
4393 kind
= expr2
->ts
.kind
;
4395 /* Guard against recursion. */
4397 if (expr2
->external_blas
)
4400 if (type
!= expr1
->ts
.type
|| kind
!= expr1
->ts
.kind
)
4403 if (type
== BT_REAL
)
4406 blas_name
= "sgemm";
4408 blas_name
= "dgemm";
4412 else if (type
== BT_COMPLEX
)
4415 blas_name
= "cgemm";
4417 blas_name
= "zgemm";
4424 a
= expr2
->value
.function
.actual
;
4425 if (a
->expr
->rank
!= 2)
4429 if (b
->expr
->rank
!= 2)
4432 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
4433 if (matrix_a
== NULL
)
4446 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
4447 if (matrix_b
== NULL
)
4476 inserted_block
= NULL
;
4477 changed_statement
= NULL
;
4479 expr2
->external_blas
= 1;
4481 /* We do not handle data dependencies yet. */
4482 if (gfc_check_dependency (expr1
, matrix_a
, true)
4483 || gfc_check_dependency (expr1
, matrix_b
, true))
4486 /* Generate the if statement and hang it into the tree. */
4487 if_limit
= inline_limit_check (matrix_a
, matrix_b
, flag_blas_matmul_limit
);
4489 (*current_code
) = if_limit
;
4491 if_limit
->block
->next
= co
;
4493 call
= XCNEW (gfc_code
);
4494 call
->loc
= co
->loc
;
4496 /* Bounds checking - a bit simpler than for inlining since we only
4497 have to take care of two-dimensional arrays here. */
4499 realloc_c
= flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
);
4500 next_code_point
= &(if_limit
->block
->block
->next
);
4502 if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
4505 // gfc_expr *a2, *b1, *c1, *c2, *a1, *b2;
4506 gfc_expr
*c1
, *a1
, *c2
, *b2
, *a2
;
4510 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4511 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4512 test
= runtime_error_ne (b1
, a2
, B_ERROR(1));
4513 *next_code_point
= test
;
4514 next_code_point
= &test
->next
;
4518 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4519 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4520 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4521 *next_code_point
= test
;
4522 next_code_point
= &test
->next
;
4524 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4525 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4526 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4527 *next_code_point
= test
;
4528 next_code_point
= &test
->next
;
4534 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4535 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4536 /* matrix_b is transposed, hence dimension 1 for the error message. */
4537 test
= runtime_error_ne (b2
, a2
, B_ERROR(1));
4538 *next_code_point
= test
;
4539 next_code_point
= &test
->next
;
4543 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4544 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4545 test
= runtime_error_ne (c1
, a1
, C_ERROR(1));
4546 *next_code_point
= test
;
4547 next_code_point
= &test
->next
;
4549 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4550 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4551 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4552 *next_code_point
= test
;
4553 next_code_point
= &test
->next
;
4559 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4560 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4561 test
= runtime_error_ne (b1
, a1
, B_ERROR(1));
4562 *next_code_point
= test
;
4563 next_code_point
= &test
->next
;
4567 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4568 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4569 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4570 *next_code_point
= test
;
4571 next_code_point
= &test
->next
;
4573 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4574 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4575 test
= runtime_error_ne (c2
, b2
, C_ERROR(2));
4576 *next_code_point
= test
;
4577 next_code_point
= &test
->next
;
4582 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
4583 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
4584 test
= runtime_error_ne (b2
, a1
, B_ERROR(1));
4585 *next_code_point
= test
;
4586 next_code_point
= &test
->next
;
4590 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
4591 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
4592 test
= runtime_error_ne (c1
, a2
, C_ERROR(1));
4593 *next_code_point
= test
;
4594 next_code_point
= &test
->next
;
4596 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
4597 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
4598 test
= runtime_error_ne (c2
, b1
, C_ERROR(2));
4599 *next_code_point
= test
;
4600 next_code_point
= &test
->next
;
4609 /* Handle the reallocation, if needed. */
4613 gfc_code
*lhs_alloc
;
4615 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
4616 *next_code_point
= lhs_alloc
;
4617 next_code_point
= &lhs_alloc
->next
;
4620 *next_code_point
= call
;
4621 if_limit
->next
= co_next
;
4623 /* Set up the BLAS call. */
4625 call
->op
= EXEC_CALL
;
4627 gfc_get_sym_tree (blas_name
, current_ns
, &(call
->symtree
), true);
4628 call
->symtree
->n
.sym
->attr
.subroutine
= 1;
4629 call
->symtree
->n
.sym
->attr
.procedure
= 1;
4630 call
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
4631 call
->resolved_sym
= call
->symtree
->n
.sym
;
4633 /* Argument TRANSA. */
4634 next
= gfc_get_actual_arglist ();
4635 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4638 call
->ext
.actual
= next
;
4640 /* Argument TRANSB. */
4642 next
= gfc_get_actual_arglist ();
4643 next
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &co
->loc
,
4645 actual
->next
= next
;
4647 c1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (a
->expr
), 1,
4648 gfc_integer_4_kind
);
4649 c2
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 2,
4650 gfc_integer_4_kind
);
4652 b1
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (b
->expr
), 1,
4653 gfc_integer_4_kind
);
4657 next
= gfc_get_actual_arglist ();
4659 actual
->next
= next
;
4663 next
= gfc_get_actual_arglist ();
4665 actual
->next
= next
;
4669 next
= gfc_get_actual_arglist ();
4671 actual
->next
= next
;
4673 /* Argument ALPHA - set to one. */
4675 next
= gfc_get_actual_arglist ();
4676 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4677 if (type
== BT_REAL
)
4678 mpfr_set_ui (next
->expr
->value
.real
, 1, GFC_RND_MODE
);
4680 mpc_set_ui (next
->expr
->value
.complex, 1, GFC_MPC_RND_MODE
);
4681 actual
->next
= next
;
4685 next
= gfc_get_actual_arglist ();
4686 next
->expr
= gfc_copy_expr (matrix_a
);
4687 actual
->next
= next
;
4691 next
= gfc_get_actual_arglist ();
4692 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_a
),
4693 1, gfc_integer_4_kind
);
4694 actual
->next
= next
;
4698 next
= gfc_get_actual_arglist ();
4699 next
->expr
= gfc_copy_expr (matrix_b
);
4700 actual
->next
= next
;
4704 next
= gfc_get_actual_arglist ();
4705 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (matrix_b
),
4706 1, gfc_integer_4_kind
);
4707 actual
->next
= next
;
4709 /* Argument BETA - set to zero. */
4711 next
= gfc_get_actual_arglist ();
4712 next
->expr
= gfc_get_constant_expr (type
, kind
, &co
->loc
);
4713 if (type
== BT_REAL
)
4714 mpfr_set_ui (next
->expr
->value
.real
, 0, GFC_RND_MODE
);
4716 mpc_set_ui (next
->expr
->value
.complex, 0, GFC_MPC_RND_MODE
);
4717 actual
->next
= next
;
4722 next
= gfc_get_actual_arglist ();
4723 next
->expr
= gfc_copy_expr (expr1
);
4724 actual
->next
= next
;
4728 next
= gfc_get_actual_arglist ();
4729 next
->expr
= get_array_inq_function (GFC_ISYM_SIZE
, gfc_copy_expr (expr1
),
4730 1, gfc_integer_4_kind
);
4731 actual
->next
= next
;
4737 /* Code for index interchange for loops which are grouped together in DO
4738 CONCURRENT or FORALL statements. This is currently only applied if the
4739 iterations are grouped together in a single statement.
4741 For this transformation, it is assumed that memory access in strides is
4742 expensive, and that loops which access later indices (which access memory
4743 in bigger strides) should be moved to the first loops.
4745 For this, a loop over all the statements is executed, counting the times
4746 that the loop iteration values are accessed in each index. The loop
4747 indices are then sorted to minimize access to later indices from inner
4750 /* Type for holding index information. */
4754 gfc_forall_iterator
*fa
;
4756 int n
[GFC_MAX_DIMENSIONS
];
4759 /* Callback function to determine if an expression is the
4760 corresponding variable. */
4763 has_var (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
, void *data
)
4765 gfc_expr
*expr
= *e
;
4768 if (expr
->expr_type
!= EXPR_VARIABLE
)
4771 sym
= (gfc_symbol
*) data
;
4772 return sym
== expr
->symtree
->n
.sym
;
4775 /* Callback function to calculate the cost of a certain index. */
4778 index_cost (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4788 if (expr
->expr_type
!= EXPR_VARIABLE
)
4792 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4794 if (ref
->type
== REF_ARRAY
)
4800 if (ar
== NULL
|| ar
->type
!= AR_ELEMENT
)
4803 ind
= (ind_type
*) data
;
4804 for (i
= 0; i
< ar
->dimen
; i
++)
4806 for (j
=0; ind
[j
].sym
!= NULL
; j
++)
4808 if (gfc_expr_walker (&ar
->start
[i
], has_var
, (void *) (ind
[j
].sym
)))
4815 /* Callback function for qsort, to sort the loop indices. */
4818 loop_comp (const void *e1
, const void *e2
)
4820 const ind_type
*i1
= (const ind_type
*) e1
;
4821 const ind_type
*i2
= (const ind_type
*) e2
;
4824 for (i
=GFC_MAX_DIMENSIONS
-1; i
>= 0; i
--)
4826 if (i1
->n
[i
] != i2
->n
[i
])
4827 return i1
->n
[i
] - i2
->n
[i
];
4829 /* All other things being equal, let's not change the ordering. */
4830 return i2
->num
- i1
->num
;
4833 /* Main function to do the index interchange. */
4836 index_interchange (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
4837 void *data ATTRIBUTE_UNUSED
)
4842 gfc_forall_iterator
*fa
;
4846 if (co
->op
!= EXEC_FORALL
&& co
->op
!= EXEC_DO_CONCURRENT
)
4850 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4853 /* Nothing to reorder. */
4857 ind
= XALLOCAVEC (ind_type
, n_iter
+ 1);
4860 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4862 ind
[i
].sym
= fa
->var
->symtree
->n
.sym
;
4864 for (j
=0; j
<GFC_MAX_DIMENSIONS
; j
++)
4869 ind
[n_iter
].sym
= NULL
;
4870 ind
[n_iter
].fa
= NULL
;
4872 gfc_code_walker (c
, gfc_dummy_code_callback
, index_cost
, (void *) ind
);
4873 qsort ((void *) ind
, n_iter
, sizeof (ind_type
), loop_comp
);
4875 /* Do the actual index interchange. */
4876 co
->ext
.forall_iterator
= fa
= ind
[0].fa
;
4877 for (i
=1; i
<n_iter
; i
++)
4879 fa
->next
= ind
[i
].fa
;
4884 if (flag_warn_frontend_loop_interchange
)
4886 for (i
=1; i
<n_iter
; i
++)
4888 if (ind
[i
-1].num
> ind
[i
].num
)
4890 gfc_warning (OPT_Wfrontend_loop_interchange
,
4891 "Interchanging loops at %L", &co
->loc
);
4900 #define WALK_SUBEXPR(NODE) \
4903 result = gfc_expr_walker (&(NODE), exprfn, data); \
4908 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
4910 /* Walk expression *E, calling EXPRFN on each expression in it. */
4913 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
4917 int walk_subtrees
= 1;
4918 gfc_actual_arglist
*a
;
4922 int result
= exprfn (e
, &walk_subtrees
, data
);
4926 switch ((*e
)->expr_type
)
4929 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
4930 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
4933 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
4934 WALK_SUBEXPR (a
->expr
);
4938 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
4939 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
4940 WALK_SUBEXPR (a
->expr
);
4943 case EXPR_STRUCTURE
:
4945 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
4946 c
= gfc_constructor_next (c
))
4948 if (c
->iterator
== NULL
)
4949 WALK_SUBEXPR (c
->expr
);
4953 WALK_SUBEXPR (c
->expr
);
4955 WALK_SUBEXPR (c
->iterator
->var
);
4956 WALK_SUBEXPR (c
->iterator
->start
);
4957 WALK_SUBEXPR (c
->iterator
->end
);
4958 WALK_SUBEXPR (c
->iterator
->step
);
4962 if ((*e
)->expr_type
!= EXPR_ARRAY
)
4965 /* Fall through to the variable case in order to walk the
4969 case EXPR_SUBSTRING
:
4971 for (r
= (*e
)->ref
; r
; r
= r
->next
)
4980 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
4982 for (i
=0; i
< ar
->dimen
; i
++)
4984 WALK_SUBEXPR (ar
->start
[i
]);
4985 WALK_SUBEXPR (ar
->end
[i
]);
4986 WALK_SUBEXPR (ar
->stride
[i
]);
4993 WALK_SUBEXPR (r
->u
.ss
.start
);
4994 WALK_SUBEXPR (r
->u
.ss
.end
);
5010 #define WALK_SUBCODE(NODE) \
5013 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
5019 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
5020 on each expression in it. If any of the hooks returns non-zero, that
5021 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
5022 no subcodes or subexpressions are traversed. */
5025 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
5028 for (; *c
; c
= &(*c
)->next
)
5030 int walk_subtrees
= 1;
5031 int result
= codefn (c
, &walk_subtrees
, data
);
5038 gfc_actual_arglist
*a
;
5040 gfc_association_list
*alist
;
5041 bool saved_in_omp_workshare
;
5042 bool saved_in_where
;
5044 /* There might be statement insertions before the current code,
5045 which must not affect the expression walker. */
5048 saved_in_omp_workshare
= in_omp_workshare
;
5049 saved_in_where
= in_where
;
5055 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
5056 if (co
->ext
.block
.assoc
)
5058 bool saved_in_assoc_list
= in_assoc_list
;
5060 in_assoc_list
= true;
5061 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
5062 WALK_SUBEXPR (alist
->target
);
5064 in_assoc_list
= saved_in_assoc_list
;
5071 WALK_SUBEXPR (co
->ext
.iterator
->var
);
5072 WALK_SUBEXPR (co
->ext
.iterator
->start
);
5073 WALK_SUBEXPR (co
->ext
.iterator
->end
);
5074 WALK_SUBEXPR (co
->ext
.iterator
->step
);
5086 case EXEC_ASSIGN_CALL
:
5087 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5088 WALK_SUBEXPR (a
->expr
);
5092 WALK_SUBEXPR (co
->expr1
);
5093 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
5094 WALK_SUBEXPR (a
->expr
);
5098 WALK_SUBEXPR (co
->expr1
);
5100 for (b
= co
->block
; b
; b
= b
->block
)
5103 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
5105 WALK_SUBEXPR (cp
->low
);
5106 WALK_SUBEXPR (cp
->high
);
5108 WALK_SUBCODE (b
->next
);
5113 case EXEC_DEALLOCATE
:
5116 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
5117 WALK_SUBEXPR (a
->expr
);
5122 case EXEC_DO_CONCURRENT
:
5124 gfc_forall_iterator
*fa
;
5125 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5127 WALK_SUBEXPR (fa
->var
);
5128 WALK_SUBEXPR (fa
->start
);
5129 WALK_SUBEXPR (fa
->end
);
5130 WALK_SUBEXPR (fa
->stride
);
5132 if (co
->op
== EXEC_FORALL
)
5138 WALK_SUBEXPR (co
->ext
.open
->unit
);
5139 WALK_SUBEXPR (co
->ext
.open
->file
);
5140 WALK_SUBEXPR (co
->ext
.open
->status
);
5141 WALK_SUBEXPR (co
->ext
.open
->access
);
5142 WALK_SUBEXPR (co
->ext
.open
->form
);
5143 WALK_SUBEXPR (co
->ext
.open
->recl
);
5144 WALK_SUBEXPR (co
->ext
.open
->blank
);
5145 WALK_SUBEXPR (co
->ext
.open
->position
);
5146 WALK_SUBEXPR (co
->ext
.open
->action
);
5147 WALK_SUBEXPR (co
->ext
.open
->delim
);
5148 WALK_SUBEXPR (co
->ext
.open
->pad
);
5149 WALK_SUBEXPR (co
->ext
.open
->iostat
);
5150 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
5151 WALK_SUBEXPR (co
->ext
.open
->convert
);
5152 WALK_SUBEXPR (co
->ext
.open
->decimal
);
5153 WALK_SUBEXPR (co
->ext
.open
->encoding
);
5154 WALK_SUBEXPR (co
->ext
.open
->round
);
5155 WALK_SUBEXPR (co
->ext
.open
->sign
);
5156 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
5157 WALK_SUBEXPR (co
->ext
.open
->id
);
5158 WALK_SUBEXPR (co
->ext
.open
->newunit
);
5159 WALK_SUBEXPR (co
->ext
.open
->share
);
5160 WALK_SUBEXPR (co
->ext
.open
->cc
);
5164 WALK_SUBEXPR (co
->ext
.close
->unit
);
5165 WALK_SUBEXPR (co
->ext
.close
->status
);
5166 WALK_SUBEXPR (co
->ext
.close
->iostat
);
5167 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
5170 case EXEC_BACKSPACE
:
5174 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
5175 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
5176 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
5180 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
5181 WALK_SUBEXPR (co
->ext
.inquire
->file
);
5182 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
5183 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
5184 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
5185 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
5186 WALK_SUBEXPR (co
->ext
.inquire
->number
);
5187 WALK_SUBEXPR (co
->ext
.inquire
->named
);
5188 WALK_SUBEXPR (co
->ext
.inquire
->name
);
5189 WALK_SUBEXPR (co
->ext
.inquire
->access
);
5190 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
5191 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
5192 WALK_SUBEXPR (co
->ext
.inquire
->form
);
5193 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
5194 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
5195 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
5196 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
5197 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
5198 WALK_SUBEXPR (co
->ext
.inquire
->position
);
5199 WALK_SUBEXPR (co
->ext
.inquire
->action
);
5200 WALK_SUBEXPR (co
->ext
.inquire
->read
);
5201 WALK_SUBEXPR (co
->ext
.inquire
->write
);
5202 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
5203 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
5204 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
5205 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
5206 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
5207 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
5208 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
5209 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
5210 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
5211 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
5212 WALK_SUBEXPR (co
->ext
.inquire
->id
);
5213 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
5214 WALK_SUBEXPR (co
->ext
.inquire
->size
);
5215 WALK_SUBEXPR (co
->ext
.inquire
->round
);
5219 WALK_SUBEXPR (co
->ext
.wait
->unit
);
5220 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
5221 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
5222 WALK_SUBEXPR (co
->ext
.wait
->id
);
5227 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
5228 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
5229 WALK_SUBEXPR (co
->ext
.dt
->rec
);
5230 WALK_SUBEXPR (co
->ext
.dt
->advance
);
5231 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
5232 WALK_SUBEXPR (co
->ext
.dt
->size
);
5233 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
5234 WALK_SUBEXPR (co
->ext
.dt
->id
);
5235 WALK_SUBEXPR (co
->ext
.dt
->pos
);
5236 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
5237 WALK_SUBEXPR (co
->ext
.dt
->blank
);
5238 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
5239 WALK_SUBEXPR (co
->ext
.dt
->delim
);
5240 WALK_SUBEXPR (co
->ext
.dt
->pad
);
5241 WALK_SUBEXPR (co
->ext
.dt
->round
);
5242 WALK_SUBEXPR (co
->ext
.dt
->sign
);
5243 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
5246 case EXEC_OMP_PARALLEL
:
5247 case EXEC_OMP_PARALLEL_DO
:
5248 case EXEC_OMP_PARALLEL_DO_SIMD
:
5249 case EXEC_OMP_PARALLEL_SECTIONS
:
5251 in_omp_workshare
= false;
5253 /* This goto serves as a shortcut to avoid code
5254 duplication or a larger if or switch statement. */
5255 goto check_omp_clauses
;
5257 case EXEC_OMP_WORKSHARE
:
5258 case EXEC_OMP_PARALLEL_WORKSHARE
:
5260 in_omp_workshare
= true;
5264 case EXEC_OMP_CRITICAL
:
5265 case EXEC_OMP_DISTRIBUTE
:
5266 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
5267 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5268 case EXEC_OMP_DISTRIBUTE_SIMD
:
5270 case EXEC_OMP_DO_SIMD
:
5271 case EXEC_OMP_ORDERED
:
5272 case EXEC_OMP_SECTIONS
:
5273 case EXEC_OMP_SINGLE
:
5274 case EXEC_OMP_END_SINGLE
:
5276 case EXEC_OMP_TASKLOOP
:
5277 case EXEC_OMP_TASKLOOP_SIMD
:
5278 case EXEC_OMP_TARGET
:
5279 case EXEC_OMP_TARGET_DATA
:
5280 case EXEC_OMP_TARGET_ENTER_DATA
:
5281 case EXEC_OMP_TARGET_EXIT_DATA
:
5282 case EXEC_OMP_TARGET_PARALLEL
:
5283 case EXEC_OMP_TARGET_PARALLEL_DO
:
5284 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
5285 case EXEC_OMP_TARGET_SIMD
:
5286 case EXEC_OMP_TARGET_TEAMS
:
5287 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
5288 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5289 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5290 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5291 case EXEC_OMP_TARGET_UPDATE
:
5293 case EXEC_OMP_TEAMS
:
5294 case EXEC_OMP_TEAMS_DISTRIBUTE
:
5295 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5296 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5297 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
5299 /* Come to this label only from the
5300 EXEC_OMP_PARALLEL_* cases above. */
5304 if (co
->ext
.omp_clauses
)
5306 gfc_omp_namelist
*n
;
5307 static int list_types
[]
5308 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
5309 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
5311 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
5312 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
5313 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
5314 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
5315 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
5316 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
5317 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
5318 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
5319 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
5320 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
5321 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
5322 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
5323 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
5324 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
5325 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
5326 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
5328 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
5330 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
5332 WALK_SUBEXPR (n
->expr
);
5339 WALK_SUBEXPR (co
->expr1
);
5340 WALK_SUBEXPR (co
->expr2
);
5341 WALK_SUBEXPR (co
->expr3
);
5342 WALK_SUBEXPR (co
->expr4
);
5343 for (b
= co
->block
; b
; b
= b
->block
)
5345 WALK_SUBEXPR (b
->expr1
);
5346 WALK_SUBEXPR (b
->expr2
);
5347 WALK_SUBCODE (b
->next
);
5350 if (co
->op
== EXEC_FORALL
)
5353 if (co
->op
== EXEC_DO
)
5356 if (co
->op
== EXEC_IF
)
5359 if (co
->op
== EXEC_SELECT
)
5362 in_omp_workshare
= saved_in_omp_workshare
;
5363 in_where
= saved_in_where
;