1 /* Pass manager for Fortran front end.
2 Copyright (C) 2010-2017 Free Software Foundation, Inc.
3 Contributed by Thomas König.
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
26 #include "dependency.h"
27 #include "constructor.h"
28 #include "intrinsic.h"
30 /* Forward declarations. */
32 static void strip_function_call (gfc_expr
*);
33 static void optimize_namespace (gfc_namespace
*);
34 static void optimize_assignment (gfc_code
*);
35 static bool optimize_op (gfc_expr
*);
36 static bool optimize_comparison (gfc_expr
*, gfc_intrinsic_op
);
37 static bool optimize_trim (gfc_expr
*);
38 static bool optimize_lexical_comparison (gfc_expr
*);
39 static void optimize_minmaxloc (gfc_expr
**);
40 static bool is_empty_string (gfc_expr
*e
);
41 static void doloop_warn (gfc_namespace
*);
42 static void optimize_reduction (gfc_namespace
*);
43 static int callback_reduction (gfc_expr
**, int *, void *);
44 static void realloc_strings (gfc_namespace
*);
45 static gfc_expr
*create_var (gfc_expr
*, const char *vname
=NULL
);
46 static int matmul_to_var_expr (gfc_expr
**, int *, void *);
47 static int matmul_to_var_code (gfc_code
**, int *, void *);
48 static int inline_matmul_assign (gfc_code
**, int *, void *);
49 static gfc_code
* create_do_loop (gfc_expr
*, gfc_expr
*, gfc_expr
*,
50 locus
*, gfc_namespace
*,
52 static gfc_expr
* check_conjg_transpose_variable (gfc_expr
*, bool *,
54 static bool has_dimen_vector_ref (gfc_expr
*);
55 static int matmul_temp_args (gfc_code
**, int *,void *data
);
58 static void check_locus (gfc_namespace
*);
61 /* How deep we are inside an argument list. */
63 static int count_arglist
;
65 /* Vector of gfc_expr ** we operate on. */
67 static vec
<gfc_expr
**> expr_array
;
69 /* Pointer to the gfc_code we currently work on - to be able to insert
70 a block before the statement. */
72 static gfc_code
**current_code
;
74 /* Pointer to the block to be inserted, and the statement we are
75 changing within the block. */
77 static gfc_code
*inserted_block
, **changed_statement
;
79 /* The namespace we are currently dealing with. */
81 static gfc_namespace
*current_ns
;
83 /* If we are within any forall loop. */
85 static int forall_level
;
87 /* Keep track of whether we are within an OMP workshare. */
89 static bool in_omp_workshare
;
91 /* Keep track of whether we are within a WHERE statement. */
95 /* Keep track of iterators for array constructors. */
97 static int iterator_level
;
99 /* Keep track of DO loop levels. */
101 static vec
<gfc_code
*> doloop_list
;
103 static int doloop_level
;
105 /* Vector of gfc_expr * to keep track of DO loops. */
107 struct my_struct
*evec
;
109 /* Keep track of association lists. */
111 static bool in_assoc_list
;
113 /* Counter for temporary variables. */
115 static int var_num
= 1;
117 /* What sort of matrix we are dealing with when inlining MATMUL. */
119 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
121 /* Keep track of the number of expressions we have inserted so far
126 /* Entry point - run all passes for a namespace. */
129 gfc_run_passes (gfc_namespace
*ns
)
132 /* Warn about dubious DO loops where the index might
137 doloop_list
.release ();
144 if (flag_frontend_optimize
)
146 optimize_namespace (ns
);
147 optimize_reduction (ns
);
148 if (flag_dump_fortran_optimized
)
149 gfc_dump_parse_tree (ns
, stdout
);
151 expr_array
.release ();
154 gfc_get_errors (&w
, &e
);
158 if (flag_realloc_lhs
)
159 realloc_strings (ns
);
164 /* Callback function: Warn if there is no location information in a
168 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
169 void *data ATTRIBUTE_UNUSED
)
172 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
173 gfc_warning_internal (0, "No location in statement");
179 /* Callback function: Warn if there is no location information in an
183 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
184 void *data ATTRIBUTE_UNUSED
)
187 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
188 gfc_warning_internal (0, "No location in expression near %L",
189 &((*current_code
)->loc
));
193 /* Run check for missing location information. */
196 check_locus (gfc_namespace
*ns
)
198 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
200 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
202 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
209 /* Callback for each gfc_code node invoked from check_realloc_strings.
210 For an allocatable LHS string which also appears as a variable on
222 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
223 void *data ATTRIBUTE_UNUSED
)
225 gfc_expr
*expr1
, *expr2
;
231 if (co
->op
!= EXEC_ASSIGN
)
235 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
236 || !gfc_expr_attr(expr1
).allocatable
237 || !expr1
->ts
.deferred
)
240 expr2
= gfc_discard_nops (co
->expr2
);
241 if (expr2
->expr_type
!= EXPR_VARIABLE
)
244 found_substr
= false;
245 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
247 if (ref
->type
== REF_SUBSTRING
)
256 if (!gfc_check_dependency (expr1
, expr2
, true))
259 /* gfc_check_dependency doesn't always pick up identical expressions.
260 However, eliminating the above sends the compiler into an infinite
261 loop on valid expressions. Without this check, the gimplifier emits
262 an ICE for a = a, where a is deferred character length. */
263 if (!gfc_dep_compare_expr (expr1
, expr2
))
267 inserted_block
= NULL
;
268 changed_statement
= NULL
;
269 n
= create_var (expr2
, "realloc_string");
274 /* Callback for each gfc_code node invoked through gfc_code_walker
275 from optimize_namespace. */
278 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
279 void *data ATTRIBUTE_UNUSED
)
286 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
287 || op
== EXEC_CALL_PPC
)
293 inserted_block
= NULL
;
294 changed_statement
= NULL
;
296 if (op
== EXEC_ASSIGN
)
297 optimize_assignment (*c
);
301 /* Callback for each gfc_expr node invoked through gfc_code_walker
302 from optimize_namespace. */
305 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
306 void *data ATTRIBUTE_UNUSED
)
310 if ((*e
)->expr_type
== EXPR_FUNCTION
)
313 function_expr
= true;
316 function_expr
= false;
318 if (optimize_trim (*e
))
319 gfc_simplify_expr (*e
, 0);
321 if (optimize_lexical_comparison (*e
))
322 gfc_simplify_expr (*e
, 0);
324 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
325 gfc_simplify_expr (*e
, 0);
327 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
328 switch ((*e
)->value
.function
.isym
->id
)
330 case GFC_ISYM_MINLOC
:
331 case GFC_ISYM_MAXLOC
:
332 optimize_minmaxloc (e
);
344 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
345 function is a scalar, just copy it; otherwise returns the new element, the
346 old one can be freed. */
349 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
351 gfc_expr
*fcn
, *e
= c
->expr
;
353 fcn
= gfc_copy_expr (e
);
356 gfc_constructor_base newbase
;
358 gfc_constructor
*new_c
;
361 new_expr
= gfc_get_expr ();
362 new_expr
->expr_type
= EXPR_ARRAY
;
363 new_expr
->ts
= e
->ts
;
364 new_expr
->where
= e
->where
;
366 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
367 new_c
->iterator
= c
->iterator
;
368 new_expr
->value
.constructor
= newbase
;
376 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
378 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
379 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
380 fn
->value
.function
.isym
->name
,
381 fn
->where
, 3, fcn
, NULL
, NULL
);
382 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
383 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
384 fn
->value
.function
.isym
->name
,
385 fn
->where
, 2, fcn
, NULL
);
387 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
389 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
395 /* Callback function for optimzation of reductions to scalars. Transform ANY
396 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
397 correspondingly. Handly only the simple cases without MASK and DIM. */
400 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
401 void *data ATTRIBUTE_UNUSED
)
406 gfc_actual_arglist
*a
;
407 gfc_actual_arglist
*dim
;
409 gfc_expr
*res
, *new_expr
;
410 gfc_actual_arglist
*mask
;
414 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
415 || fn
->value
.function
.isym
== NULL
)
418 id
= fn
->value
.function
.isym
->id
;
420 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
421 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
424 a
= fn
->value
.function
.actual
;
426 /* Don't handle MASK or DIM. */
430 if (dim
->expr
!= NULL
)
433 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
436 if ( mask
->expr
!= NULL
)
442 if (arg
->expr_type
!= EXPR_ARRAY
)
451 case GFC_ISYM_PRODUCT
:
452 op
= INTRINSIC_TIMES
;
467 c
= gfc_constructor_first (arg
->value
.constructor
);
469 /* Don't do any simplififcation if we have
470 - no element in the constructor or
471 - only have a single element in the array which contains an
477 res
= copy_walk_reduction_arg (c
, fn
);
479 c
= gfc_constructor_next (c
);
482 new_expr
= gfc_get_expr ();
483 new_expr
->ts
= fn
->ts
;
484 new_expr
->expr_type
= EXPR_OP
;
485 new_expr
->rank
= fn
->rank
;
486 new_expr
->where
= fn
->where
;
487 new_expr
->value
.op
.op
= op
;
488 new_expr
->value
.op
.op1
= res
;
489 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
491 c
= gfc_constructor_next (c
);
494 gfc_simplify_expr (res
, 0);
501 /* Callback function for common function elimination, called from cfe_expr_0.
502 Put all eligible function expressions into expr_array. */
505 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
506 void *data ATTRIBUTE_UNUSED
)
509 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
512 /* We don't do character functions with unknown charlens. */
513 if ((*e
)->ts
.type
== BT_CHARACTER
514 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
515 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
518 /* We don't do function elimination within FORALL statements, it can
519 lead to wrong-code in certain circumstances. */
521 if (forall_level
> 0)
524 /* Function elimination inside an iterator could lead to functions which
525 depend on iterator variables being moved outside. FIXME: We should check
526 if the functions do indeed depend on the iterator variable. */
528 if (iterator_level
> 0)
531 /* If we don't know the shape at compile time, we create an allocatable
532 temporary variable to hold the intermediate result, but only if
533 allocation on assignment is active. */
535 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
538 /* Skip the test for pure functions if -faggressive-function-elimination
540 if ((*e
)->value
.function
.esym
)
542 /* Don't create an array temporary for elemental functions. */
543 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
546 /* Only eliminate potentially impure functions if the
547 user specifically requested it. */
548 if (!flag_aggressive_function_elimination
549 && !(*e
)->value
.function
.esym
->attr
.pure
550 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
554 if ((*e
)->value
.function
.isym
)
556 /* Conversions are handled on the fly by the middle end,
557 transpose during trans-* stages and TRANSFER by the middle end. */
558 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
559 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
560 || gfc_inline_intrinsic_function_p (*e
))
563 /* Don't create an array temporary for elemental functions,
564 as this would be wasteful of memory.
565 FIXME: Create a scalar temporary during scalarization. */
566 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
569 if (!(*e
)->value
.function
.isym
->pure
)
573 expr_array
.safe_push (e
);
577 /* Auxiliary function to check if an expression is a temporary created by
581 is_fe_temp (gfc_expr
*e
)
583 if (e
->expr_type
!= EXPR_VARIABLE
)
586 return e
->symtree
->n
.sym
->attr
.fe_temp
;
589 /* Determine the length of a string, if it can be evaluated as a constant
590 expression. Return a newly allocated gfc_expr or NULL on failure.
591 If the user specified a substring which is potentially longer than
592 the string itself, the string will be padded with spaces, which
596 constant_string_length (gfc_expr
*e
)
606 length
= e
->ts
.u
.cl
->length
;
607 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
608 return gfc_copy_expr(length
);
611 /* Return length of substring, if constant. */
612 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
614 if (ref
->type
== REF_SUBSTRING
615 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
617 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
620 mpz_add_ui (res
->value
.integer
, value
, 1);
626 /* Return length of char symbol, if constant. */
628 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
629 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
630 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
636 /* Insert a block at the current position unless it has already
637 been inserted; in this case use the one already there. */
639 static gfc_namespace
*
644 /* If the block hasn't already been created, do so. */
645 if (inserted_block
== NULL
)
647 inserted_block
= XCNEW (gfc_code
);
648 inserted_block
->op
= EXEC_BLOCK
;
649 inserted_block
->loc
= (*current_code
)->loc
;
650 ns
= gfc_build_block_ns (current_ns
);
651 inserted_block
->ext
.block
.ns
= ns
;
652 inserted_block
->ext
.block
.assoc
= NULL
;
654 ns
->code
= *current_code
;
656 /* If the statement has a label, make sure it is transferred to
657 the newly created block. */
659 if ((*current_code
)->here
)
661 inserted_block
->here
= (*current_code
)->here
;
662 (*current_code
)->here
= NULL
;
665 inserted_block
->next
= (*current_code
)->next
;
666 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
667 (*current_code
)->next
= NULL
;
668 /* Insert the BLOCK at the right position. */
669 *current_code
= inserted_block
;
670 ns
->parent
= current_ns
;
673 ns
= inserted_block
->ext
.block
.ns
;
678 /* Returns a new expression (a variable) to be used in place of the old one,
679 with an optional assignment statement before the current statement to set
680 the value of the variable. Creates a new BLOCK for the statement if that
681 hasn't already been done and puts the statement, plus the newly created
682 variables, in that block. Special cases: If the expression is constant or
683 a temporary which has already been created, just copy it. */
686 create_var (gfc_expr
* e
, const char *vname
)
688 char name
[GFC_MAX_SYMBOL_LEN
+1];
689 gfc_symtree
*symtree
;
697 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
698 return gfc_copy_expr (e
);
700 ns
= insert_block ();
703 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
705 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
707 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
710 symbol
= symtree
->n
.sym
;
715 symbol
->as
= gfc_get_array_spec ();
716 symbol
->as
->rank
= e
->rank
;
718 if (e
->shape
== NULL
)
720 /* We don't know the shape at compile time, so we use an
722 symbol
->as
->type
= AS_DEFERRED
;
723 symbol
->attr
.allocatable
= 1;
727 symbol
->as
->type
= AS_EXPLICIT
;
728 /* Copy the shape. */
729 for (i
=0; i
<e
->rank
; i
++)
733 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
735 mpz_set_si (p
->value
.integer
, 1);
736 symbol
->as
->lower
[i
] = p
;
738 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
740 mpz_set (q
->value
.integer
, e
->shape
[i
]);
741 symbol
->as
->upper
[i
] = q
;
747 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
751 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
752 length
= constant_string_length (e
);
754 symbol
->ts
.u
.cl
->length
= length
;
757 symbol
->attr
.allocatable
= 1;
762 symbol
->attr
.flavor
= FL_VARIABLE
;
763 symbol
->attr
.referenced
= 1;
764 symbol
->attr
.dimension
= e
->rank
> 0;
765 symbol
->attr
.fe_temp
= 1;
766 gfc_commit_symbol (symbol
);
768 result
= gfc_get_expr ();
769 result
->expr_type
= EXPR_VARIABLE
;
771 result
->ts
.deferred
= deferred
;
772 result
->rank
= e
->rank
;
773 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
774 result
->symtree
= symtree
;
775 result
->where
= e
->where
;
778 result
->ref
= gfc_get_ref ();
779 result
->ref
->type
= REF_ARRAY
;
780 result
->ref
->u
.ar
.type
= AR_FULL
;
781 result
->ref
->u
.ar
.where
= e
->where
;
782 result
->ref
->u
.ar
.dimen
= e
->rank
;
783 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
784 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
785 if (warn_array_temporaries
)
786 gfc_warning (OPT_Warray_temporaries
,
787 "Creating array temporary at %L", &(e
->where
));
790 /* Generate the new assignment. */
791 n
= XCNEW (gfc_code
);
793 n
->loc
= (*current_code
)->loc
;
794 n
->next
= *changed_statement
;
795 n
->expr1
= gfc_copy_expr (result
);
797 *changed_statement
= n
;
803 /* Warn about function elimination. */
806 do_warn_function_elimination (gfc_expr
*e
)
808 if (e
->expr_type
!= EXPR_FUNCTION
)
810 if (e
->value
.function
.esym
)
811 gfc_warning (OPT_Wfunction_elimination
,
812 "Removing call to function %qs at %L",
813 e
->value
.function
.esym
->name
, &(e
->where
));
814 else if (e
->value
.function
.isym
)
815 gfc_warning (OPT_Wfunction_elimination
,
816 "Removing call to function %qs at %L",
817 e
->value
.function
.isym
->name
, &(e
->where
));
819 /* Callback function for the code walker for doing common function
820 elimination. This builds up the list of functions in the expression
821 and goes through them to detect duplicates, which it then replaces
825 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
826 void *data ATTRIBUTE_UNUSED
)
832 /* Don't do this optimization within OMP workshare or ASSOC lists. */
834 if (in_omp_workshare
|| in_assoc_list
)
840 expr_array
.release ();
842 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
844 /* Walk through all the functions. */
846 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
848 /* Skip if the function has been replaced by a variable already. */
849 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
856 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
859 newvar
= create_var (*ei
, "fcn");
861 if (warn_function_elimination
)
862 do_warn_function_elimination (*ej
);
865 *ej
= gfc_copy_expr (newvar
);
872 /* We did all the necessary walking in this function. */
877 /* Callback function for common function elimination, called from
878 gfc_code_walker. This keeps track of the current code, in order
879 to insert statements as needed. */
882 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
885 inserted_block
= NULL
;
886 changed_statement
= NULL
;
888 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
889 and allocation on assigment are prohibited inside WHERE, and finally
890 masking an expression would lead to wrong-code when replacing
893 b = sum(foo(a) + foo(a))
904 if ((*c
)->op
== EXEC_WHERE
)
914 /* Dummy function for expression call back, for use when we
915 really don't want to do any walking. */
918 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
919 void *data ATTRIBUTE_UNUSED
)
925 /* Dummy function for code callback, for use when we really
926 don't want to do anything. */
928 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
929 int *walk_subtrees ATTRIBUTE_UNUSED
,
930 void *data ATTRIBUTE_UNUSED
)
935 /* Code callback function for converting
942 This is because common function elimination would otherwise place the
943 temporary variables outside the loop. */
946 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
947 void *data ATTRIBUTE_UNUSED
)
950 gfc_code
*c_if1
, *c_if2
, *c_exit
;
952 gfc_expr
*e_not
, *e_cond
;
954 if (co
->op
!= EXEC_DO_WHILE
)
957 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
962 /* Generate the condition of the if statement, which is .not. the original
964 e_not
= gfc_get_expr ();
965 e_not
->ts
= e_cond
->ts
;
966 e_not
->where
= e_cond
->where
;
967 e_not
->expr_type
= EXPR_OP
;
968 e_not
->value
.op
.op
= INTRINSIC_NOT
;
969 e_not
->value
.op
.op1
= e_cond
;
971 /* Generate the EXIT statement. */
972 c_exit
= XCNEW (gfc_code
);
973 c_exit
->op
= EXEC_EXIT
;
974 c_exit
->ext
.which_construct
= co
;
975 c_exit
->loc
= co
->loc
;
977 /* Generate the IF statement. */
978 c_if2
= XCNEW (gfc_code
);
980 c_if2
->expr1
= e_not
;
981 c_if2
->next
= c_exit
;
982 c_if2
->loc
= co
->loc
;
984 /* ... plus the one to chain it to. */
985 c_if1
= XCNEW (gfc_code
);
987 c_if1
->block
= c_if2
;
988 c_if1
->loc
= co
->loc
;
990 /* Make the DO WHILE loop into a DO block by replacing the condition
991 with a true constant. */
992 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
994 /* Hang the generated if statement into the loop body. */
996 loopblock
= co
->block
->next
;
997 co
->block
->next
= c_if1
;
998 c_if1
->next
= loopblock
;
1003 /* Code callback function for converting
1016 because otherwise common function elimination would place the BLOCKs
1017 into the wrong place. */
1020 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1021 void *data ATTRIBUTE_UNUSED
)
1024 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1026 if (co
->op
!= EXEC_IF
)
1029 /* This loop starts out with the first ELSE statement. */
1030 else_stmt
= co
->block
->block
;
1032 while (else_stmt
!= NULL
)
1034 gfc_code
*next_else
;
1036 /* If there is no condition, we're done. */
1037 if (else_stmt
->expr1
== NULL
)
1040 next_else
= else_stmt
->block
;
1042 /* Generate the new IF statement. */
1043 c_if2
= XCNEW (gfc_code
);
1044 c_if2
->op
= EXEC_IF
;
1045 c_if2
->expr1
= else_stmt
->expr1
;
1046 c_if2
->next
= else_stmt
->next
;
1047 c_if2
->loc
= else_stmt
->loc
;
1048 c_if2
->block
= next_else
;
1050 /* ... plus the one to chain it to. */
1051 c_if1
= XCNEW (gfc_code
);
1052 c_if1
->op
= EXEC_IF
;
1053 c_if1
->block
= c_if2
;
1054 c_if1
->loc
= else_stmt
->loc
;
1056 /* Insert the new IF after the ELSE. */
1057 else_stmt
->expr1
= NULL
;
1058 else_stmt
->next
= c_if1
;
1059 else_stmt
->block
= NULL
;
1061 else_stmt
= next_else
;
1063 /* Don't walk subtrees. */
1067 /* Optimize a namespace, including all contained namespaces. */
1070 optimize_namespace (gfc_namespace
*ns
)
1072 gfc_namespace
*saved_ns
= gfc_current_ns
;
1074 gfc_current_ns
= ns
;
1077 in_assoc_list
= false;
1078 in_omp_workshare
= false;
1080 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1081 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1082 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1083 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1084 if (flag_inline_matmul_limit
!= 0)
1090 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1095 gfc_code_walker (&ns
->code
, matmul_temp_args
, dummy_expr_callback
,
1097 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1101 /* BLOCKs are handled in the expression walker below. */
1102 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1104 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1105 optimize_namespace (ns
);
1107 gfc_current_ns
= saved_ns
;
1110 /* Handle dependencies for allocatable strings which potentially redefine
1111 themselves in an assignment. */
1114 realloc_strings (gfc_namespace
*ns
)
1117 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1119 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1121 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1122 realloc_strings (ns
);
1128 optimize_reduction (gfc_namespace
*ns
)
1131 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1132 callback_reduction
, NULL
);
1134 /* BLOCKs are handled in the expression walker below. */
1135 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1137 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1138 optimize_reduction (ns
);
1142 /* Replace code like
1145 a = matmul(b,c) ; a = a + d
1146 where the array function is not elemental and not allocatable
1147 and does not depend on the left-hand side.
1151 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1159 if (e
->expr_type
== EXPR_OP
)
1161 switch (e
->value
.op
.op
)
1163 /* Unary operators and exponentiation: Only look at a single
1166 case INTRINSIC_UPLUS
:
1167 case INTRINSIC_UMINUS
:
1168 case INTRINSIC_PARENTHESES
:
1169 case INTRINSIC_POWER
:
1170 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1174 case INTRINSIC_CONCAT
:
1175 /* Do not do string concatenations. */
1179 /* Binary operators. */
1180 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1183 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1189 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1190 && ! (e
->value
.function
.esym
1191 && (e
->value
.function
.esym
->attr
.elemental
1192 || e
->value
.function
.esym
->attr
.allocatable
1193 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1194 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1195 && ! (e
->value
.function
.isym
1196 && (e
->value
.function
.isym
->elemental
1197 || e
->ts
.type
!= c
->expr1
->ts
.type
1198 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1199 && ! gfc_inline_intrinsic_function_p (e
))
1205 /* Insert a new assignment statement after the current one. */
1206 n
= XCNEW (gfc_code
);
1207 n
->op
= EXEC_ASSIGN
;
1212 n
->expr1
= gfc_copy_expr (c
->expr1
);
1213 n
->expr2
= c
->expr2
;
1214 new_expr
= gfc_copy_expr (c
->expr1
);
1222 /* Nothing to optimize. */
1226 /* Remove unneeded TRIMs at the end of expressions. */
1229 remove_trim (gfc_expr
*rhs
)
1237 /* Check for a // b // trim(c). Looping is probably not
1238 necessary because the parser usually generates
1239 (// (// a b ) trim(c) ) , but better safe than sorry. */
1241 while (rhs
->expr_type
== EXPR_OP
1242 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1243 rhs
= rhs
->value
.op
.op2
;
1245 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1246 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1248 strip_function_call (rhs
);
1249 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1257 /* Optimizations for an assignment. */
1260 optimize_assignment (gfc_code
* c
)
1262 gfc_expr
*lhs
, *rhs
;
1267 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1269 /* Optimize a = trim(b) to a = b. */
1272 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1273 if (is_empty_string (rhs
))
1274 rhs
->value
.character
.length
= 0;
1277 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1278 optimize_binop_array_assignment (c
, &rhs
, false);
1282 /* Remove an unneeded function call, modifying the expression.
1283 This replaces the function call with the value of its
1284 first argument. The rest of the argument list is freed. */
1287 strip_function_call (gfc_expr
*e
)
1290 gfc_actual_arglist
*a
;
1292 a
= e
->value
.function
.actual
;
1294 /* We should have at least one argument. */
1295 gcc_assert (a
->expr
!= NULL
);
1299 /* Free the remaining arglist, if any. */
1301 gfc_free_actual_arglist (a
->next
);
1303 /* Graft the argument expression onto the original function. */
1309 /* Optimization of lexical comparison functions. */
1312 optimize_lexical_comparison (gfc_expr
*e
)
1314 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1317 switch (e
->value
.function
.isym
->id
)
1320 return optimize_comparison (e
, INTRINSIC_LE
);
1323 return optimize_comparison (e
, INTRINSIC_GE
);
1326 return optimize_comparison (e
, INTRINSIC_GT
);
1329 return optimize_comparison (e
, INTRINSIC_LT
);
1337 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1338 do CHARACTER because of possible pessimization involving character
1342 combine_array_constructor (gfc_expr
*e
)
1345 gfc_expr
*op1
, *op2
;
1348 gfc_constructor
*c
, *new_c
;
1349 gfc_constructor_base oldbase
, newbase
;
1352 /* Array constructors have rank one. */
1356 /* Don't try to combine association lists, this makes no sense
1357 and leads to an ICE. */
1361 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1362 if (forall_level
> 0)
1365 /* Inside an iterator, things can get hairy; we are likely to create
1366 an invalid temporary variable. */
1367 if (iterator_level
> 0)
1370 op1
= e
->value
.op
.op1
;
1371 op2
= e
->value
.op
.op2
;
1376 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1377 scalar_first
= false;
1378 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1380 scalar_first
= true;
1381 op1
= e
->value
.op
.op2
;
1382 op2
= e
->value
.op
.op1
;
1387 if (op2
->ts
.type
== BT_CHARACTER
)
1390 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1392 oldbase
= op1
->value
.constructor
;
1394 e
->expr_type
= EXPR_ARRAY
;
1396 for (c
= gfc_constructor_first (oldbase
); c
;
1397 c
= gfc_constructor_next (c
))
1399 new_expr
= gfc_get_expr ();
1400 new_expr
->ts
= e
->ts
;
1401 new_expr
->expr_type
= EXPR_OP
;
1402 new_expr
->rank
= c
->expr
->rank
;
1403 new_expr
->where
= c
->expr
->where
;
1404 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1408 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1409 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1413 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1414 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1417 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1418 new_c
->iterator
= c
->iterator
;
1422 gfc_free_expr (op1
);
1423 gfc_free_expr (op2
);
1424 gfc_free_expr (scalar
);
1426 e
->value
.constructor
= newbase
;
1430 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1431 2**k into ishift(1,k) */
1434 optimize_power (gfc_expr
*e
)
1436 gfc_expr
*op1
, *op2
;
1437 gfc_expr
*iand
, *ishft
;
1439 if (e
->ts
.type
!= BT_INTEGER
)
1442 op1
= e
->value
.op
.op1
;
1444 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1447 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1449 gfc_free_expr (op1
);
1451 op2
= e
->value
.op
.op2
;
1456 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1457 "_internal_iand", e
->where
, 2, op2
,
1458 gfc_get_int_expr (e
->ts
.kind
,
1461 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1462 "_internal_ishft", e
->where
, 2, iand
,
1463 gfc_get_int_expr (e
->ts
.kind
,
1466 e
->value
.op
.op
= INTRINSIC_MINUS
;
1467 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1468 e
->value
.op
.op2
= ishft
;
1471 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1473 gfc_free_expr (op1
);
1475 op2
= e
->value
.op
.op2
;
1479 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1480 "_internal_ishft", e
->where
, 2,
1481 gfc_get_int_expr (e
->ts
.kind
,
1488 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1490 op2
= e
->value
.op
.op2
;
1494 gfc_free_expr (op1
);
1495 gfc_free_expr (op2
);
1497 e
->expr_type
= EXPR_CONSTANT
;
1498 e
->value
.op
.op1
= NULL
;
1499 e
->value
.op
.op2
= NULL
;
1500 mpz_init_set_si (e
->value
.integer
, 1);
1501 /* Typespec and location are still OK. */
1508 /* Recursive optimization of operators. */
1511 optimize_op (gfc_expr
*e
)
1515 gfc_intrinsic_op op
= e
->value
.op
.op
;
1519 /* Only use new-style comparisons. */
1522 case INTRINSIC_EQ_OS
:
1526 case INTRINSIC_GE_OS
:
1530 case INTRINSIC_LE_OS
:
1534 case INTRINSIC_NE_OS
:
1538 case INTRINSIC_GT_OS
:
1542 case INTRINSIC_LT_OS
:
1558 changed
= optimize_comparison (e
, op
);
1561 /* Look at array constructors. */
1562 case INTRINSIC_PLUS
:
1563 case INTRINSIC_MINUS
:
1564 case INTRINSIC_TIMES
:
1565 case INTRINSIC_DIVIDE
:
1566 return combine_array_constructor (e
) || changed
;
1568 case INTRINSIC_POWER
:
1569 return optimize_power (e
);
1579 /* Return true if a constant string contains only blanks. */
1582 is_empty_string (gfc_expr
*e
)
1586 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1589 for (i
=0; i
< e
->value
.character
.length
; i
++)
1591 if (e
->value
.character
.string
[i
] != ' ')
1599 /* Insert a call to the intrinsic len_trim. Use a different name for
1600 the symbol tree so we don't run into trouble when the user has
1601 renamed len_trim for some reason. */
1604 get_len_trim_call (gfc_expr
*str
, int kind
)
1607 gfc_actual_arglist
*actual_arglist
, *next
;
1609 fcn
= gfc_get_expr ();
1610 fcn
->expr_type
= EXPR_FUNCTION
;
1611 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1612 actual_arglist
= gfc_get_actual_arglist ();
1613 actual_arglist
->expr
= str
;
1614 next
= gfc_get_actual_arglist ();
1615 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1616 actual_arglist
->next
= next
;
1618 fcn
->value
.function
.actual
= actual_arglist
;
1619 fcn
->where
= str
->where
;
1620 fcn
->ts
.type
= BT_INTEGER
;
1621 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1623 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1624 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1625 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1626 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1627 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1628 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1629 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1630 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1635 /* Optimize expressions for equality. */
1638 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1640 gfc_expr
*op1
, *op2
;
1644 gfc_actual_arglist
*firstarg
, *secondarg
;
1646 if (e
->expr_type
== EXPR_OP
)
1650 op1
= e
->value
.op
.op1
;
1651 op2
= e
->value
.op
.op2
;
1653 else if (e
->expr_type
== EXPR_FUNCTION
)
1655 /* One of the lexical comparison functions. */
1656 firstarg
= e
->value
.function
.actual
;
1657 secondarg
= firstarg
->next
;
1658 op1
= firstarg
->expr
;
1659 op2
= secondarg
->expr
;
1664 /* Strip off unneeded TRIM calls from string comparisons. */
1666 change
= remove_trim (op1
);
1668 if (remove_trim (op2
))
1671 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1672 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1673 handles them well). However, there are also cases that need a non-scalar
1674 argument. For example the any intrinsic. See PR 45380. */
1678 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1680 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1681 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1683 bool empty_op1
, empty_op2
;
1684 empty_op1
= is_empty_string (op1
);
1685 empty_op2
= is_empty_string (op2
);
1687 if (empty_op1
|| empty_op2
)
1693 /* This can only happen when an error for comparing
1694 characters of different kinds has already been issued. */
1695 if (empty_op1
&& empty_op2
)
1698 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1699 str
= empty_op1
? op2
: op1
;
1701 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1705 gfc_free_expr (op1
);
1707 gfc_free_expr (op2
);
1711 e
->value
.op
.op1
= fcn
;
1712 e
->value
.op
.op2
= zero
;
1717 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1719 if (flag_finite_math_only
1720 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1721 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1723 eq
= gfc_dep_compare_expr (op1
, op2
);
1726 /* Replace A // B < A // C with B < C, and A // B < C // B
1728 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1729 && op1
->expr_type
== EXPR_OP
1730 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1731 && op2
->expr_type
== EXPR_OP
1732 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1734 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1735 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1736 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1737 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1739 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1741 /* Watch out for 'A ' // x vs. 'A' // x. */
1743 if (op1_left
->expr_type
== EXPR_CONSTANT
1744 && op2_left
->expr_type
== EXPR_CONSTANT
1745 && op1_left
->value
.character
.length
1746 != op2_left
->value
.character
.length
)
1754 firstarg
->expr
= op1_right
;
1755 secondarg
->expr
= op2_right
;
1759 e
->value
.op
.op1
= op1_right
;
1760 e
->value
.op
.op2
= op2_right
;
1762 optimize_comparison (e
, op
);
1766 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1772 firstarg
->expr
= op1_left
;
1773 secondarg
->expr
= op2_left
;
1777 e
->value
.op
.op1
= op1_left
;
1778 e
->value
.op
.op2
= op2_left
;
1781 optimize_comparison (e
, op
);
1788 /* eq can only be -1, 0 or 1 at this point. */
1816 gfc_internal_error ("illegal OP in optimize_comparison");
1820 /* Replace the expression by a constant expression. The typespec
1821 and where remains the way it is. */
1824 e
->expr_type
= EXPR_CONSTANT
;
1825 e
->value
.logical
= result
;
1833 /* Optimize a trim function by replacing it with an equivalent substring
1834 involving a call to len_trim. This only works for expressions where
1835 variables are trimmed. Return true if anything was modified. */
1838 optimize_trim (gfc_expr
*e
)
1843 gfc_ref
**rr
= NULL
;
1845 /* Don't do this optimization within an argument list, because
1846 otherwise aliasing issues may occur. */
1848 if (count_arglist
!= 1)
1851 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1852 || e
->value
.function
.isym
== NULL
1853 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1856 a
= e
->value
.function
.actual
->expr
;
1858 if (a
->expr_type
!= EXPR_VARIABLE
)
1861 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1863 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1866 /* Follow all references to find the correct place to put the newly
1867 created reference. FIXME: Also handle substring references and
1868 array references. Array references cause strange regressions at
1873 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1875 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1880 strip_function_call (e
);
1885 /* Create the reference. */
1887 ref
= gfc_get_ref ();
1888 ref
->type
= REF_SUBSTRING
;
1890 /* Set the start of the reference. */
1892 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1894 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1896 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1898 /* Set the end of the reference to the call to len_trim. */
1900 ref
->u
.ss
.end
= fcn
;
1901 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1906 /* Optimize minloc(b), where b is rank 1 array, into
1907 (/ minloc(b, dim=1) /), and similarly for maxloc,
1908 as the latter forms are expanded inline. */
1911 optimize_minmaxloc (gfc_expr
**e
)
1914 gfc_actual_arglist
*a
;
1918 || fn
->value
.function
.actual
== NULL
1919 || fn
->value
.function
.actual
->expr
== NULL
1920 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1923 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1924 (*e
)->shape
= fn
->shape
;
1927 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1929 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1930 strcpy (name
, fn
->value
.function
.name
);
1931 p
= strstr (name
, "loc0");
1933 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
1934 if (fn
->value
.function
.actual
->next
)
1936 a
= fn
->value
.function
.actual
->next
;
1937 gcc_assert (a
->expr
== NULL
);
1941 a
= gfc_get_actual_arglist ();
1942 fn
->value
.function
.actual
->next
= a
;
1944 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1946 mpz_set_ui (a
->expr
->value
.integer
, 1);
1949 /* Callback function for code checking that we do not pass a DO variable to an
1950 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1953 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1954 void *data ATTRIBUTE_UNUSED
)
1958 gfc_formal_arglist
*f
;
1959 gfc_actual_arglist
*a
;
1964 /* If the doloop_list grew, we have to truncate it here. */
1966 if ((unsigned) doloop_level
< doloop_list
.length())
1967 doloop_list
.truncate (doloop_level
);
1973 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1974 doloop_list
.safe_push (co
);
1976 doloop_list
.safe_push ((gfc_code
*) NULL
);
1981 if (co
->resolved_sym
== NULL
)
1984 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1986 /* Withot a formal arglist, there is only unknown INTENT,
1987 which we don't check for. */
1995 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
2002 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
2004 if (a
->expr
&& a
->expr
->symtree
2005 && a
->expr
->symtree
->n
.sym
== do_sym
)
2007 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2008 gfc_error_now ("Variable %qs at %L set to undefined "
2009 "value inside loop beginning at %L as "
2010 "INTENT(OUT) argument to subroutine %qs",
2011 do_sym
->name
, &a
->expr
->where
,
2012 &doloop_list
[i
]->loc
,
2013 co
->symtree
->n
.sym
->name
);
2014 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2015 gfc_error_now ("Variable %qs at %L not definable inside "
2016 "loop beginning at %L as INTENT(INOUT) "
2017 "argument to subroutine %qs",
2018 do_sym
->name
, &a
->expr
->where
,
2019 &doloop_list
[i
]->loc
,
2020 co
->symtree
->n
.sym
->name
);
2034 /* Callback function for functions checking that we do not pass a DO variable
2035 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2038 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2039 void *data ATTRIBUTE_UNUSED
)
2041 gfc_formal_arglist
*f
;
2042 gfc_actual_arglist
*a
;
2048 if (expr
->expr_type
!= EXPR_FUNCTION
)
2051 /* Intrinsic functions don't modify their arguments. */
2053 if (expr
->value
.function
.isym
)
2056 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2058 /* Without a formal arglist, there is only unknown INTENT,
2059 which we don't check for. */
2063 a
= expr
->value
.function
.actual
;
2067 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
2074 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2076 if (a
->expr
&& a
->expr
->symtree
2077 && a
->expr
->symtree
->n
.sym
== do_sym
)
2079 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2080 gfc_error_now ("Variable %qs at %L set to undefined value "
2081 "inside loop beginning at %L as INTENT(OUT) "
2082 "argument to function %qs", do_sym
->name
,
2083 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2084 expr
->symtree
->n
.sym
->name
);
2085 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2086 gfc_error_now ("Variable %qs at %L not definable inside loop"
2087 " beginning at %L as INTENT(INOUT) argument to"
2088 " function %qs", do_sym
->name
,
2089 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2090 expr
->symtree
->n
.sym
->name
);
2101 doloop_warn (gfc_namespace
*ns
)
2103 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2106 /* This selction deals with inlining calls to MATMUL. */
2108 /* Replace calls to matmul outside of straight assignments with a temporary
2109 variable so that later inlining will work. */
2112 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2116 bool *found
= (bool *) data
;
2120 if (e
->expr_type
!= EXPR_FUNCTION
2121 || e
->value
.function
.isym
== NULL
2122 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2125 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2129 /* Check if this is already in the form c = matmul(a,b). */
2131 if ((*current_code
)->expr2
== e
)
2134 n
= create_var (e
, "matmul");
2136 /* If create_var is unable to create a variable (for example if
2137 -fno-realloc-lhs is in force with a variable that does not have bounds
2138 known at compile-time), just return. */
2148 /* Set current_code and associated variables so that matmul_to_var_expr can
2152 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2153 void *data ATTRIBUTE_UNUSED
)
2155 if (current_code
!= c
)
2158 inserted_block
= NULL
;
2159 changed_statement
= NULL
;
2166 /* Take a statement of the shape c = matmul(a,b) and create temporaries
2167 for a and b if there is a dependency between the arguments and the
2168 result variable or if a or b are the result of calculations that cannot
2169 be handled by the inliner. */
2172 matmul_temp_args (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2173 void *data ATTRIBUTE_UNUSED
)
2175 gfc_expr
*expr1
, *expr2
;
2177 gfc_actual_arglist
*a
, *b
;
2179 gfc_expr
*matrix_a
, *matrix_b
;
2180 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2184 if (co
->op
!= EXEC_ASSIGN
)
2187 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2191 /* This has some duplication with inline_matmul_assign. This
2192 is because the creation of temporary variables could still fail,
2193 and inline_matmul_assign still needs to be able to handle these
2198 if (expr2
->expr_type
!= EXPR_FUNCTION
2199 || expr2
->value
.function
.isym
== NULL
2200 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2204 a
= expr2
->value
.function
.actual
;
2205 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
2206 if (matrix_a
!= NULL
)
2208 if (matrix_a
->expr_type
== EXPR_VARIABLE
2209 && (gfc_check_dependency (matrix_a
, expr1
, true)
2210 || has_dimen_vector_ref (matrix_a
)))
2218 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
2219 if (matrix_b
!= NULL
)
2221 if (matrix_b
->expr_type
== EXPR_VARIABLE
2222 && (gfc_check_dependency (matrix_b
, expr1
, true)
2223 || has_dimen_vector_ref (matrix_b
)))
2229 if (!a_tmp
&& !b_tmp
)
2233 inserted_block
= NULL
;
2234 changed_statement
= NULL
;
2238 at
= create_var (a
->expr
,"mma");
2245 bt
= create_var (b
->expr
,"mmb");
2252 /* Auxiliary function to build and simplify an array inquiry function.
2253 dim is zero-based. */
2256 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2259 gfc_expr
*dim_arg
, *kind
;
2265 case GFC_ISYM_LBOUND
:
2266 name
= "_gfortran_lbound";
2269 case GFC_ISYM_UBOUND
:
2270 name
= "_gfortran_ubound";
2274 name
= "_gfortran_size";
2281 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2282 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2283 gfc_index_integer_kind
);
2285 ec
= gfc_copy_expr (e
);
2286 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2288 gfc_simplify_expr (fcn
, 0);
2292 /* Builds a logical expression. */
2295 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2300 ts
.type
= BT_LOGICAL
;
2301 ts
.kind
= gfc_default_logical_kind
;
2302 res
= gfc_get_expr ();
2303 res
->where
= e1
->where
;
2304 res
->expr_type
= EXPR_OP
;
2305 res
->value
.op
.op
= op
;
2306 res
->value
.op
.op1
= e1
;
2307 res
->value
.op
.op2
= e2
;
2314 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2315 compatible typespecs. */
2318 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2322 res
= gfc_get_expr ();
2324 res
->where
= e1
->where
;
2325 res
->expr_type
= EXPR_OP
;
2326 res
->value
.op
.op
= op
;
2327 res
->value
.op
.op1
= e1
;
2328 res
->value
.op
.op2
= e2
;
2329 gfc_simplify_expr (res
, 0);
2333 /* Generate the IF statement for a runtime check if we want to do inlining or
2334 not - putting in the code for both branches and putting it into the syntax
2335 tree is the caller's responsibility. For fixed array sizes, this should be
2336 removed by DCE. Only called for rank-two matrices A and B. */
2339 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2341 gfc_expr
*inline_limit
;
2342 gfc_code
*if_1
, *if_2
, *else_2
;
2343 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2347 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2349 /* Calculation is done in real to avoid integer overflow. */
2351 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2353 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2355 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2358 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2359 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2360 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2364 ts
.kind
= gfc_default_real_kind
;
2365 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2366 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2367 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2369 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2370 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2372 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2373 gfc_simplify_expr (cond
, 0);
2375 else_2
= XCNEW (gfc_code
);
2376 else_2
->op
= EXEC_IF
;
2377 else_2
->loc
= a
->where
;
2379 if_2
= XCNEW (gfc_code
);
2382 if_2
->loc
= a
->where
;
2383 if_2
->block
= else_2
;
2385 if_1
= XCNEW (gfc_code
);
2388 if_1
->loc
= a
->where
;
2394 /* Insert code to issue a runtime error if the expressions are not equal. */
2397 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2400 gfc_code
*if_1
, *if_2
;
2402 gfc_actual_arglist
*a1
, *a2
, *a3
;
2404 gcc_assert (e1
->where
.lb
);
2405 /* Build the call to runtime_error. */
2406 c
= XCNEW (gfc_code
);
2410 /* Get a null-terminated message string. */
2412 a1
= gfc_get_actual_arglist ();
2413 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2414 msg
, strlen(msg
)+1);
2417 /* Pass the value of the first expression. */
2418 a2
= gfc_get_actual_arglist ();
2419 a2
->expr
= gfc_copy_expr (e1
);
2422 /* Pass the value of the second expression. */
2423 a3
= gfc_get_actual_arglist ();
2424 a3
->expr
= gfc_copy_expr (e2
);
2427 gfc_check_fe_runtime_error (c
->ext
.actual
);
2428 gfc_resolve_fe_runtime_error (c
);
2430 if_2
= XCNEW (gfc_code
);
2432 if_2
->loc
= e1
->where
;
2435 if_1
= XCNEW (gfc_code
);
2438 if_1
->loc
= e1
->where
;
2440 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2441 gfc_simplify_expr (cond
, 0);
2447 /* Handle matrix reallocation. Caller is responsible to insert into
2450 For the two-dimensional case, build
2452 if (allocated(c)) then
2453 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2455 allocate (c(size(a,1), size(b,2)))
2458 allocate (c(size(a,1),size(b,2)))
2461 and for the other cases correspondingly.
2465 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2466 enum matrix_case m_case
)
2469 gfc_expr
*allocated
, *alloc_expr
;
2470 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2471 gfc_code
*else_alloc
;
2472 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2474 gfc_expr
*cond
, *ne1
, *ne2
;
2476 if (warn_realloc_lhs
)
2477 gfc_warning (OPT_Wrealloc_lhs
,
2478 "Code for reallocating the allocatable array at %L will "
2479 "be added", &c
->where
);
2481 alloc_expr
= gfc_copy_expr (c
);
2483 ar
= gfc_find_array_ref (alloc_expr
);
2484 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2486 /* c comes in as a full ref. Change it into a copy and make it into an
2487 element ref so it has the right form for for ALLOCATE. In the same
2488 switch statement, also generate the size comparison for the secod IF
2491 ar
->type
= AR_ELEMENT
;
2496 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2497 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2498 ne1
= build_logical_expr (INTRINSIC_NE
,
2499 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2500 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2501 ne2
= build_logical_expr (INTRINSIC_NE
,
2502 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2503 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2504 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2508 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2509 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2511 ne1
= build_logical_expr (INTRINSIC_NE
,
2512 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2513 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2514 ne2
= build_logical_expr (INTRINSIC_NE
,
2515 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2516 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2517 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2522 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2523 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2525 ne1
= build_logical_expr (INTRINSIC_NE
,
2526 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2527 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2528 ne2
= build_logical_expr (INTRINSIC_NE
,
2529 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2530 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2531 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2535 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2536 cond
= build_logical_expr (INTRINSIC_NE
,
2537 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2538 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2542 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2543 cond
= build_logical_expr (INTRINSIC_NE
,
2544 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2545 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2553 gfc_simplify_expr (cond
, 0);
2555 /* We need two identical allocate statements in two
2556 branches of the IF statement. */
2558 allocate1
= XCNEW (gfc_code
);
2559 allocate1
->op
= EXEC_ALLOCATE
;
2560 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2561 allocate1
->loc
= c
->where
;
2562 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2564 allocate_else
= XCNEW (gfc_code
);
2565 allocate_else
->op
= EXEC_ALLOCATE
;
2566 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2567 allocate_else
->loc
= c
->where
;
2568 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2570 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2571 "_gfortran_allocated", c
->where
,
2572 1, gfc_copy_expr (c
));
2574 deallocate
= XCNEW (gfc_code
);
2575 deallocate
->op
= EXEC_DEALLOCATE
;
2576 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2577 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2578 deallocate
->next
= allocate1
;
2579 deallocate
->loc
= c
->where
;
2581 if_size_2
= XCNEW (gfc_code
);
2582 if_size_2
->op
= EXEC_IF
;
2583 if_size_2
->expr1
= cond
;
2584 if_size_2
->loc
= c
->where
;
2585 if_size_2
->next
= deallocate
;
2587 if_size_1
= XCNEW (gfc_code
);
2588 if_size_1
->op
= EXEC_IF
;
2589 if_size_1
->block
= if_size_2
;
2590 if_size_1
->loc
= c
->where
;
2592 else_alloc
= XCNEW (gfc_code
);
2593 else_alloc
->op
= EXEC_IF
;
2594 else_alloc
->loc
= c
->where
;
2595 else_alloc
->next
= allocate_else
;
2597 if_alloc_2
= XCNEW (gfc_code
);
2598 if_alloc_2
->op
= EXEC_IF
;
2599 if_alloc_2
->expr1
= allocated
;
2600 if_alloc_2
->loc
= c
->where
;
2601 if_alloc_2
->next
= if_size_1
;
2602 if_alloc_2
->block
= else_alloc
;
2604 if_alloc_1
= XCNEW (gfc_code
);
2605 if_alloc_1
->op
= EXEC_IF
;
2606 if_alloc_1
->block
= if_alloc_2
;
2607 if_alloc_1
->loc
= c
->where
;
2612 /* Callback function for has_function_or_op. */
2615 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2616 void *data ATTRIBUTE_UNUSED
)
2621 return (*e
)->expr_type
== EXPR_FUNCTION
2622 || (*e
)->expr_type
== EXPR_OP
;
2625 /* Returns true if the expression contains a function. */
2628 has_function_or_op (gfc_expr
**e
)
2633 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2636 /* Freeze (assign to a temporary variable) a single expression. */
2639 freeze_expr (gfc_expr
**ep
)
2642 if (has_function_or_op (ep
))
2644 ne
= create_var (*ep
, "freeze");
2649 /* Go through an expression's references and assign them to temporary
2650 variables if they contain functions. This is usually done prior to
2651 front-end scalarization to avoid multiple invocations of functions. */
2654 freeze_references (gfc_expr
*e
)
2660 for (r
=e
->ref
; r
; r
=r
->next
)
2662 if (r
->type
== REF_SUBSTRING
)
2664 if (r
->u
.ss
.start
!= NULL
)
2665 freeze_expr (&r
->u
.ss
.start
);
2667 if (r
->u
.ss
.end
!= NULL
)
2668 freeze_expr (&r
->u
.ss
.end
);
2670 else if (r
->type
== REF_ARRAY
)
2679 for (i
=0; i
<ar
->dimen
; i
++)
2681 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2683 freeze_expr (&ar
->start
[i
]);
2684 freeze_expr (&ar
->end
[i
]);
2685 freeze_expr (&ar
->stride
[i
]);
2687 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2689 freeze_expr (&ar
->start
[i
]);
2695 for (i
=0; i
<ar
->dimen
; i
++)
2696 freeze_expr (&ar
->start
[i
]);
2706 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2709 convert_to_index_kind (gfc_expr
*e
)
2713 gcc_assert (e
!= NULL
);
2715 res
= gfc_copy_expr (e
);
2717 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2719 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2723 ts
.type
= BT_INTEGER
;
2724 ts
.kind
= gfc_index_integer_kind
;
2726 gfc_convert_type_warn (e
, &ts
, 2, 0);
2732 /* Function to create a DO loop including creation of the
2733 iteration variable. gfc_expr are copied.*/
2736 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2737 gfc_namespace
*ns
, char *vname
)
2740 char name
[GFC_MAX_SYMBOL_LEN
+1];
2741 gfc_symtree
*symtree
;
2746 /* Create an expression for the iteration variable. */
2748 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2750 sprintf (name
, "__var_%d_do", var_num
++);
2753 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2756 /* Create the loop variable. */
2758 symbol
= symtree
->n
.sym
;
2759 symbol
->ts
.type
= BT_INTEGER
;
2760 symbol
->ts
.kind
= gfc_index_integer_kind
;
2761 symbol
->attr
.flavor
= FL_VARIABLE
;
2762 symbol
->attr
.referenced
= 1;
2763 symbol
->attr
.dimension
= 0;
2764 symbol
->attr
.fe_temp
= 1;
2765 gfc_commit_symbol (symbol
);
2767 i
= gfc_get_expr ();
2768 i
->expr_type
= EXPR_VARIABLE
;
2772 i
->symtree
= symtree
;
2774 /* ... and the nested DO statements. */
2775 n
= XCNEW (gfc_code
);
2778 n
->ext
.iterator
= gfc_get_iterator ();
2779 n
->ext
.iterator
->var
= i
;
2780 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2781 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2783 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2785 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2788 n2
= XCNEW (gfc_code
);
2796 /* Get the upper bound of the DO loops for matmul along a dimension. This
2800 get_size_m1 (gfc_expr
*e
, int dimen
)
2805 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2807 res
= gfc_get_constant_expr (BT_INTEGER
,
2808 gfc_index_integer_kind
, &e
->where
);
2809 mpz_sub_ui (res
->value
.integer
, size
, 1);
2814 res
= get_operand (INTRINSIC_MINUS
,
2815 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2816 gfc_get_int_expr (gfc_index_integer_kind
,
2818 gfc_simplify_expr (res
, 0);
2824 /* Function to return a scalarized expression. It is assumed that indices are
2825 zero based to make generation of DO loops easier. A zero as index will
2826 access the first element along a dimension. Single element references will
2827 be skipped. A NULL as an expression will be replaced by a full reference.
2828 This assumes that the index loops have gfc_index_integer_kind, and that all
2829 references have been frozen. */
2832 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2841 e
= gfc_copy_expr(e_in
);
2845 ar
= gfc_find_array_ref (e
);
2847 /* We scalarize count_index variables, reducing the rank by count_index. */
2849 e
->rank
= rank
- count_index
;
2851 was_fullref
= ar
->type
== AR_FULL
;
2854 ar
->type
= AR_ELEMENT
;
2856 ar
->type
= AR_SECTION
;
2858 /* Loop over the indices. For each index, create the expression
2859 index * stride + lbound(e, dim). */
2862 for (i
=0; i
< ar
->dimen
; i
++)
2864 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2866 if (index
[i_index
] != NULL
)
2868 gfc_expr
*lbound
, *nindex
;
2871 loopvar
= gfc_copy_expr (index
[i_index
]);
2877 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2878 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2882 ts
.type
= BT_INTEGER
;
2883 ts
.kind
= gfc_index_integer_kind
;
2884 gfc_convert_type (tmp
, &ts
, 2);
2886 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2891 /* Calculate the lower bound of the expression. */
2894 lbound
= gfc_copy_expr (ar
->start
[i
]);
2895 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2899 ts
.type
= BT_INTEGER
;
2900 ts
.kind
= gfc_index_integer_kind
;
2901 gfc_convert_type (lbound
, &ts
, 2);
2910 lbound_e
= gfc_copy_expr (e_in
);
2912 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2913 if (ref
->type
== REF_ARRAY
2914 && (ref
->u
.ar
.type
== AR_FULL
2915 || ref
->u
.ar
.type
== AR_SECTION
))
2920 gfc_free_ref_list (ref
->next
);
2926 /* Look at full individual sections, like a(:). The first index
2927 is the lbound of a full ref. */
2933 for (j
= 0; j
< ar
->dimen
; j
++)
2935 gfc_free_expr (ar
->start
[j
]);
2936 ar
->start
[j
] = NULL
;
2937 gfc_free_expr (ar
->end
[j
]);
2939 gfc_free_expr (ar
->stride
[j
]);
2940 ar
->stride
[j
] = NULL
;
2943 /* We have to get rid of the shape, if there is one. Do
2944 so by freeing it and calling gfc_resolve to rebuild
2945 it, if necessary. */
2947 if (lbound_e
->shape
)
2948 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2950 lbound_e
->rank
= ar
->dimen
;
2951 gfc_resolve_expr (lbound_e
);
2953 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2955 gfc_free_expr (lbound_e
);
2958 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2960 gfc_free_expr (ar
->start
[i
]);
2961 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2963 gfc_free_expr (ar
->end
[i
]);
2965 gfc_free_expr (ar
->stride
[i
]);
2966 ar
->stride
[i
] = NULL
;
2967 gfc_simplify_expr (ar
->start
[i
], 0);
2969 else if (was_fullref
)
2971 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2980 /* Helper function to check for a dimen vector as subscript. */
2983 has_dimen_vector_ref (gfc_expr
*e
)
2988 ar
= gfc_find_array_ref (e
);
2990 if (ar
->type
== AR_FULL
)
2993 for (i
=0; i
<ar
->dimen
; i
++)
2994 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
3000 /* If handed an expression of the form
3004 check if A can be handled by matmul and return if there is an uneven number
3005 of CONJG calls. Return a pointer to the array when everything is OK, NULL
3006 otherwise. The caller has to check for the correct rank. */
3009 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
3016 if (e
->expr_type
== EXPR_VARIABLE
)
3018 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
3021 else if (e
->expr_type
== EXPR_FUNCTION
)
3023 if (e
->value
.function
.isym
== NULL
)
3026 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
3028 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
3029 *transpose
= !*transpose
;
3035 e
= e
->value
.function
.actual
->expr
;
3042 /* Inline assignments of the form c = matmul(a,b).
3043 Handle only the cases currently where b and c are rank-two arrays.
3045 This basically translates the code to
3051 do k=0, size(a, 2)-1
3052 do i=0, size(a, 1)-1
3053 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
3054 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
3055 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
3056 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
3065 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
3066 void *data ATTRIBUTE_UNUSED
)
3069 gfc_expr
*expr1
, *expr2
;
3070 gfc_expr
*matrix_a
, *matrix_b
;
3071 gfc_actual_arglist
*a
, *b
;
3072 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
3074 gfc_expr
*u1
, *u2
, *u3
;
3076 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
3078 gfc_expr
*var_1
, *var_2
, *var_3
;
3081 gfc_intrinsic_op op_times
, op_plus
;
3082 enum matrix_case m_case
;
3084 gfc_code
*if_limit
= NULL
;
3085 gfc_code
**next_code_point
;
3086 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
3088 if (co
->op
!= EXEC_ASSIGN
)
3094 /* The BLOCKS generated for the temporary variables and FORALL don't
3096 if (forall_level
> 0)
3099 /* For now don't do anything in OpenMP workshare, it confuses
3100 its translation, which expects only the allowed statements in there.
3101 We should figure out how to parallelize this eventually. */
3102 if (in_omp_workshare
)
3107 if (expr2
->expr_type
!= EXPR_FUNCTION
3108 || expr2
->value
.function
.isym
== NULL
3109 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3113 inserted_block
= NULL
;
3114 changed_statement
= NULL
;
3116 a
= expr2
->value
.function
.actual
;
3117 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3118 if (matrix_a
== NULL
)
3122 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3123 if (matrix_b
== NULL
)
3126 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3127 || has_dimen_vector_ref (matrix_b
))
3130 /* We do not handle data dependencies yet. */
3131 if (gfc_check_dependency (expr1
, matrix_a
, true)
3132 || gfc_check_dependency (expr1
, matrix_b
, true))
3136 if (matrix_a
->rank
== 2)
3140 if (matrix_b
->rank
== 2 && !transpose_b
)
3145 if (matrix_b
->rank
== 1)
3147 else /* matrix_b->rank == 2 */
3156 else /* matrix_a->rank == 1 */
3158 if (matrix_b
->rank
== 2)
3168 ns
= insert_block ();
3170 /* Assign the type of the zero expression for initializing the resulting
3171 array, and the expression (+ and * for real, integer and complex;
3172 .and. and .or for logical. */
3174 switch(expr1
->ts
.type
)
3177 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3178 op_times
= INTRINSIC_TIMES
;
3179 op_plus
= INTRINSIC_PLUS
;
3183 op_times
= INTRINSIC_AND
;
3184 op_plus
= INTRINSIC_OR
;
3185 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3189 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3191 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3192 op_times
= INTRINSIC_TIMES
;
3193 op_plus
= INTRINSIC_PLUS
;
3197 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3199 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3200 op_times
= INTRINSIC_TIMES
;
3201 op_plus
= INTRINSIC_PLUS
;
3209 current_code
= &ns
->code
;
3211 /* Freeze the references, keeping track of how many temporary variables were
3214 freeze_references (matrix_a
);
3215 freeze_references (matrix_b
);
3216 freeze_references (expr1
);
3219 next_code_point
= current_code
;
3222 next_code_point
= &ns
->code
;
3223 for (i
=0; i
<n_vars
; i
++)
3224 next_code_point
= &(*next_code_point
)->next
;
3227 /* Take care of the inline flag. If the limit check evaluates to a
3228 constant, dead code elimination will eliminate the unneeded branch. */
3230 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3232 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3234 /* Insert the original statement into the else branch. */
3235 if_limit
->block
->block
->next
= co
;
3238 /* ... and the new ones go into the original one. */
3239 *next_code_point
= if_limit
;
3240 next_code_point
= &if_limit
->block
->next
;
3243 assign_zero
= XCNEW (gfc_code
);
3244 assign_zero
->op
= EXEC_ASSIGN
;
3245 assign_zero
->loc
= co
->loc
;
3246 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3247 assign_zero
->expr2
= zero_e
;
3249 /* Handle the reallocation, if needed. */
3250 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3252 gfc_code
*lhs_alloc
;
3254 /* Only need to check a single dimension for the A2B2 case for
3255 bounds checking, the rest will be allocated. Also check this
3258 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3263 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3264 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3265 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3266 "in MATMUL intrinsic: Is %ld, should be %ld");
3267 *next_code_point
= test
;
3268 next_code_point
= &test
->next
;
3272 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3274 *next_code_point
= lhs_alloc
;
3275 next_code_point
= &lhs_alloc
->next
;
3278 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3281 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3283 if (m_case
== A2B2
|| m_case
== A2B1
)
3285 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3286 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3287 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3288 "in MATMUL intrinsic: Is %ld, should be %ld");
3289 *next_code_point
= test
;
3290 next_code_point
= &test
->next
;
3292 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3293 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3296 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3297 "MATMUL intrinsic for dimension 1: "
3298 "is %ld, should be %ld");
3299 else if (m_case
== A2B1
)
3300 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3301 "MATMUL intrinsic: "
3302 "is %ld, should be %ld");
3305 *next_code_point
= test
;
3306 next_code_point
= &test
->next
;
3308 else if (m_case
== A1B2
)
3310 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3311 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3312 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3313 "in MATMUL intrinsic: Is %ld, should be %ld");
3314 *next_code_point
= test
;
3315 next_code_point
= &test
->next
;
3317 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3318 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3320 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3321 "MATMUL intrinsic: "
3322 "is %ld, should be %ld");
3324 *next_code_point
= test
;
3325 next_code_point
= &test
->next
;
3330 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3331 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3332 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3333 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3335 *next_code_point
= test
;
3336 next_code_point
= &test
->next
;
3339 if (m_case
== A2B2T
)
3341 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3342 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3343 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3344 "MATMUL intrinsic for dimension 1: "
3345 "is %ld, should be %ld");
3347 *next_code_point
= test
;
3348 next_code_point
= &test
->next
;
3350 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3351 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3352 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3353 "MATMUL intrinsic for dimension 2: "
3354 "is %ld, should be %ld");
3355 *next_code_point
= test
;
3356 next_code_point
= &test
->next
;
3358 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3359 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3361 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3362 "MATMUL intrnisic for dimension 2: "
3363 "is %ld, should be %ld");
3364 *next_code_point
= test
;
3365 next_code_point
= &test
->next
;
3369 if (m_case
== A2TB2
)
3371 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3372 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3374 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
3375 "MATMUL intrinsic for dimension 1: "
3376 "is %ld, should be %ld");
3378 *next_code_point
= test
;
3379 next_code_point
= &test
->next
;
3381 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3382 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3383 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3384 "MATMUL intrinsic for dimension 2: "
3385 "is %ld, should be %ld");
3386 *next_code_point
= test
;
3387 next_code_point
= &test
->next
;
3389 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3390 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3392 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
3393 "MATMUL intrnisic for dimension 2: "
3394 "is %ld, should be %ld");
3395 *next_code_point
= test
;
3396 next_code_point
= &test
->next
;
3401 *next_code_point
= assign_zero
;
3403 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3405 assign_matmul
= XCNEW (gfc_code
);
3406 assign_matmul
->op
= EXEC_ASSIGN
;
3407 assign_matmul
->loc
= co
->loc
;
3409 /* Get the bounds for the loops, create them and create the scalarized
3415 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3417 u1
= get_size_m1 (matrix_b
, 2);
3418 u2
= get_size_m1 (matrix_a
, 2);
3419 u3
= get_size_m1 (matrix_a
, 1);
3421 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3422 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3423 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3425 do_1
->block
->next
= do_2
;
3426 do_2
->block
->next
= do_3
;
3427 do_3
->block
->next
= assign_matmul
;
3429 var_1
= do_1
->ext
.iterator
->var
;
3430 var_2
= do_2
->ext
.iterator
->var
;
3431 var_3
= do_3
->ext
.iterator
->var
;
3435 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3439 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3443 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3448 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3450 u1
= get_size_m1 (matrix_b
, 1);
3451 u2
= get_size_m1 (matrix_a
, 2);
3452 u3
= get_size_m1 (matrix_a
, 1);
3454 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3455 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3456 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3458 do_1
->block
->next
= do_2
;
3459 do_2
->block
->next
= do_3
;
3460 do_3
->block
->next
= assign_matmul
;
3462 var_1
= do_1
->ext
.iterator
->var
;
3463 var_2
= do_2
->ext
.iterator
->var
;
3464 var_3
= do_3
->ext
.iterator
->var
;
3468 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3472 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3476 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3481 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3483 u1
= get_size_m1 (matrix_a
, 2);
3484 u2
= get_size_m1 (matrix_b
, 2);
3485 u3
= get_size_m1 (matrix_a
, 1);
3487 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3488 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3489 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3491 do_1
->block
->next
= do_2
;
3492 do_2
->block
->next
= do_3
;
3493 do_3
->block
->next
= assign_matmul
;
3495 var_1
= do_1
->ext
.iterator
->var
;
3496 var_2
= do_2
->ext
.iterator
->var
;
3497 var_3
= do_3
->ext
.iterator
->var
;
3501 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3505 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3509 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3514 u1
= get_size_m1 (matrix_b
, 1);
3515 u2
= get_size_m1 (matrix_a
, 1);
3517 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3518 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3520 do_1
->block
->next
= do_2
;
3521 do_2
->block
->next
= assign_matmul
;
3523 var_1
= do_1
->ext
.iterator
->var
;
3524 var_2
= do_2
->ext
.iterator
->var
;
3527 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3531 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3534 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3539 u1
= get_size_m1 (matrix_b
, 2);
3540 u2
= get_size_m1 (matrix_a
, 1);
3542 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3543 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3545 do_1
->block
->next
= do_2
;
3546 do_2
->block
->next
= assign_matmul
;
3548 var_1
= do_1
->ext
.iterator
->var
;
3549 var_2
= do_2
->ext
.iterator
->var
;
3552 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3555 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3559 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3568 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3569 matrix_a
->where
, 1, ascalar
);
3572 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3573 matrix_b
->where
, 1, bscalar
);
3575 /* First loop comes after the zero assignment. */
3576 assign_zero
->next
= do_1
;
3578 /* Build the assignment expression in the loop. */
3579 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3581 mult
= get_operand (op_times
, ascalar
, bscalar
);
3582 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3584 /* If we don't want to keep the original statement around in
3585 the else branch, we can free it. */
3587 if (if_limit
== NULL
)
3588 gfc_free_statements(co
);
3592 gfc_free_expr (zero
);
3597 #define WALK_SUBEXPR(NODE) \
3600 result = gfc_expr_walker (&(NODE), exprfn, data); \
3605 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3607 /* Walk expression *E, calling EXPRFN on each expression in it. */
3610 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3614 int walk_subtrees
= 1;
3615 gfc_actual_arglist
*a
;
3619 int result
= exprfn (e
, &walk_subtrees
, data
);
3623 switch ((*e
)->expr_type
)
3626 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3627 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3630 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3631 WALK_SUBEXPR (a
->expr
);
3635 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3636 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3637 WALK_SUBEXPR (a
->expr
);
3640 case EXPR_STRUCTURE
:
3642 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3643 c
= gfc_constructor_next (c
))
3645 if (c
->iterator
== NULL
)
3646 WALK_SUBEXPR (c
->expr
);
3650 WALK_SUBEXPR (c
->expr
);
3652 WALK_SUBEXPR (c
->iterator
->var
);
3653 WALK_SUBEXPR (c
->iterator
->start
);
3654 WALK_SUBEXPR (c
->iterator
->end
);
3655 WALK_SUBEXPR (c
->iterator
->step
);
3659 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3662 /* Fall through to the variable case in order to walk the
3666 case EXPR_SUBSTRING
:
3668 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3677 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3679 for (i
=0; i
< ar
->dimen
; i
++)
3681 WALK_SUBEXPR (ar
->start
[i
]);
3682 WALK_SUBEXPR (ar
->end
[i
]);
3683 WALK_SUBEXPR (ar
->stride
[i
]);
3690 WALK_SUBEXPR (r
->u
.ss
.start
);
3691 WALK_SUBEXPR (r
->u
.ss
.end
);
3707 #define WALK_SUBCODE(NODE) \
3710 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3716 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3717 on each expression in it. If any of the hooks returns non-zero, that
3718 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3719 no subcodes or subexpressions are traversed. */
3722 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3725 for (; *c
; c
= &(*c
)->next
)
3727 int walk_subtrees
= 1;
3728 int result
= codefn (c
, &walk_subtrees
, data
);
3735 gfc_actual_arglist
*a
;
3737 gfc_association_list
*alist
;
3738 bool saved_in_omp_workshare
;
3739 bool saved_in_where
;
3741 /* There might be statement insertions before the current code,
3742 which must not affect the expression walker. */
3745 saved_in_omp_workshare
= in_omp_workshare
;
3746 saved_in_where
= in_where
;
3752 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3753 if (co
->ext
.block
.assoc
)
3755 bool saved_in_assoc_list
= in_assoc_list
;
3757 in_assoc_list
= true;
3758 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3759 WALK_SUBEXPR (alist
->target
);
3761 in_assoc_list
= saved_in_assoc_list
;
3768 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3769 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3770 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3771 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3779 case EXEC_ASSIGN_CALL
:
3780 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3781 WALK_SUBEXPR (a
->expr
);
3785 WALK_SUBEXPR (co
->expr1
);
3786 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3787 WALK_SUBEXPR (a
->expr
);
3791 WALK_SUBEXPR (co
->expr1
);
3792 for (b
= co
->block
; b
; b
= b
->block
)
3795 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3797 WALK_SUBEXPR (cp
->low
);
3798 WALK_SUBEXPR (cp
->high
);
3800 WALK_SUBCODE (b
->next
);
3805 case EXEC_DEALLOCATE
:
3808 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3809 WALK_SUBEXPR (a
->expr
);
3814 case EXEC_DO_CONCURRENT
:
3816 gfc_forall_iterator
*fa
;
3817 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3819 WALK_SUBEXPR (fa
->var
);
3820 WALK_SUBEXPR (fa
->start
);
3821 WALK_SUBEXPR (fa
->end
);
3822 WALK_SUBEXPR (fa
->stride
);
3824 if (co
->op
== EXEC_FORALL
)
3830 WALK_SUBEXPR (co
->ext
.open
->unit
);
3831 WALK_SUBEXPR (co
->ext
.open
->file
);
3832 WALK_SUBEXPR (co
->ext
.open
->status
);
3833 WALK_SUBEXPR (co
->ext
.open
->access
);
3834 WALK_SUBEXPR (co
->ext
.open
->form
);
3835 WALK_SUBEXPR (co
->ext
.open
->recl
);
3836 WALK_SUBEXPR (co
->ext
.open
->blank
);
3837 WALK_SUBEXPR (co
->ext
.open
->position
);
3838 WALK_SUBEXPR (co
->ext
.open
->action
);
3839 WALK_SUBEXPR (co
->ext
.open
->delim
);
3840 WALK_SUBEXPR (co
->ext
.open
->pad
);
3841 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3842 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3843 WALK_SUBEXPR (co
->ext
.open
->convert
);
3844 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3845 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3846 WALK_SUBEXPR (co
->ext
.open
->round
);
3847 WALK_SUBEXPR (co
->ext
.open
->sign
);
3848 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3849 WALK_SUBEXPR (co
->ext
.open
->id
);
3850 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3851 WALK_SUBEXPR (co
->ext
.open
->share
);
3852 WALK_SUBEXPR (co
->ext
.open
->cc
);
3856 WALK_SUBEXPR (co
->ext
.close
->unit
);
3857 WALK_SUBEXPR (co
->ext
.close
->status
);
3858 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3859 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3862 case EXEC_BACKSPACE
:
3866 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3867 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3868 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3872 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3873 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3874 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3875 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3876 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3877 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3878 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3879 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3880 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3881 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3882 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3883 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3884 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3885 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3886 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3887 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3888 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3889 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3890 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3891 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3892 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3893 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3894 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3895 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3896 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3897 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3898 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3899 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3900 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3901 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3902 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3903 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3904 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3905 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3906 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3907 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3911 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3912 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3913 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3914 WALK_SUBEXPR (co
->ext
.wait
->id
);
3919 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3920 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3921 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3922 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3923 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3924 WALK_SUBEXPR (co
->ext
.dt
->size
);
3925 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3926 WALK_SUBEXPR (co
->ext
.dt
->id
);
3927 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3928 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3929 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3930 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3931 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3932 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3933 WALK_SUBEXPR (co
->ext
.dt
->round
);
3934 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3935 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3938 case EXEC_OMP_PARALLEL
:
3939 case EXEC_OMP_PARALLEL_DO
:
3940 case EXEC_OMP_PARALLEL_DO_SIMD
:
3941 case EXEC_OMP_PARALLEL_SECTIONS
:
3943 in_omp_workshare
= false;
3945 /* This goto serves as a shortcut to avoid code
3946 duplication or a larger if or switch statement. */
3947 goto check_omp_clauses
;
3949 case EXEC_OMP_WORKSHARE
:
3950 case EXEC_OMP_PARALLEL_WORKSHARE
:
3952 in_omp_workshare
= true;
3956 case EXEC_OMP_CRITICAL
:
3957 case EXEC_OMP_DISTRIBUTE
:
3958 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3959 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3960 case EXEC_OMP_DISTRIBUTE_SIMD
:
3962 case EXEC_OMP_DO_SIMD
:
3963 case EXEC_OMP_ORDERED
:
3964 case EXEC_OMP_SECTIONS
:
3965 case EXEC_OMP_SINGLE
:
3966 case EXEC_OMP_END_SINGLE
:
3968 case EXEC_OMP_TASKLOOP
:
3969 case EXEC_OMP_TASKLOOP_SIMD
:
3970 case EXEC_OMP_TARGET
:
3971 case EXEC_OMP_TARGET_DATA
:
3972 case EXEC_OMP_TARGET_ENTER_DATA
:
3973 case EXEC_OMP_TARGET_EXIT_DATA
:
3974 case EXEC_OMP_TARGET_PARALLEL
:
3975 case EXEC_OMP_TARGET_PARALLEL_DO
:
3976 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
3977 case EXEC_OMP_TARGET_SIMD
:
3978 case EXEC_OMP_TARGET_TEAMS
:
3979 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3980 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3981 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3982 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3983 case EXEC_OMP_TARGET_UPDATE
:
3985 case EXEC_OMP_TEAMS
:
3986 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3987 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3988 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3989 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3991 /* Come to this label only from the
3992 EXEC_OMP_PARALLEL_* cases above. */
3996 if (co
->ext
.omp_clauses
)
3998 gfc_omp_namelist
*n
;
3999 static int list_types
[]
4000 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
4001 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
4003 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
4004 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
4005 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
4006 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
4007 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
4008 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
4009 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
4010 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
4011 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
4012 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
4013 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
4014 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
4015 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
4016 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
4017 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
4018 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
4020 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
4022 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
4024 WALK_SUBEXPR (n
->expr
);
4031 WALK_SUBEXPR (co
->expr1
);
4032 WALK_SUBEXPR (co
->expr2
);
4033 WALK_SUBEXPR (co
->expr3
);
4034 WALK_SUBEXPR (co
->expr4
);
4035 for (b
= co
->block
; b
; b
= b
->block
)
4037 WALK_SUBEXPR (b
->expr1
);
4038 WALK_SUBEXPR (b
->expr2
);
4039 WALK_SUBCODE (b
->next
);
4042 if (co
->op
== EXEC_FORALL
)
4045 if (co
->op
== EXEC_DO
)
4048 in_omp_workshare
= saved_in_omp_workshare
;
4049 in_where
= saved_in_where
;