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
*,
54 static void check_locus (gfc_namespace
*);
57 /* How deep we are inside an argument list. */
59 static int count_arglist
;
61 /* Vector of gfc_expr ** we operate on. */
63 static vec
<gfc_expr
**> expr_array
;
65 /* Pointer to the gfc_code we currently work on - to be able to insert
66 a block before the statement. */
68 static gfc_code
**current_code
;
70 /* Pointer to the block to be inserted, and the statement we are
71 changing within the block. */
73 static gfc_code
*inserted_block
, **changed_statement
;
75 /* The namespace we are currently dealing with. */
77 static gfc_namespace
*current_ns
;
79 /* If we are within any forall loop. */
81 static int forall_level
;
83 /* Keep track of whether we are within an OMP workshare. */
85 static bool in_omp_workshare
;
87 /* Keep track of whether we are within a WHERE statement. */
91 /* Keep track of iterators for array constructors. */
93 static int iterator_level
;
95 /* Keep track of DO loop levels. */
97 static vec
<gfc_code
*> doloop_list
;
99 static int doloop_level
;
101 /* Vector of gfc_expr * to keep track of DO loops. */
103 struct my_struct
*evec
;
105 /* Keep track of association lists. */
107 static bool in_assoc_list
;
109 /* Counter for temporary variables. */
111 static int var_num
= 1;
113 /* What sort of matrix we are dealing with when inlining MATMUL. */
115 enum matrix_case
{ none
=0, A2B2
, A2B1
, A1B2
, A2B2T
, A2TB2
};
117 /* Keep track of the number of expressions we have inserted so far
122 /* Entry point - run all passes for a namespace. */
125 gfc_run_passes (gfc_namespace
*ns
)
128 /* Warn about dubious DO loops where the index might
133 doloop_list
.release ();
140 if (flag_frontend_optimize
)
142 optimize_namespace (ns
);
143 optimize_reduction (ns
);
144 if (flag_dump_fortran_optimized
)
145 gfc_dump_parse_tree (ns
, stdout
);
147 expr_array
.release ();
150 gfc_get_errors (&w
, &e
);
154 if (flag_realloc_lhs
)
155 realloc_strings (ns
);
160 /* Callback function: Warn if there is no location information in a
164 check_locus_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
165 void *data ATTRIBUTE_UNUSED
)
168 if (c
&& *c
&& (((*c
)->loc
.nextc
== NULL
) || ((*c
)->loc
.lb
== NULL
)))
169 gfc_warning_internal (0, "No location in statement");
175 /* Callback function: Warn if there is no location information in an
179 check_locus_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
180 void *data ATTRIBUTE_UNUSED
)
183 if (e
&& *e
&& (((*e
)->where
.nextc
== NULL
|| (*e
)->where
.lb
== NULL
)))
184 gfc_warning_internal (0, "No location in expression near %L",
185 &((*current_code
)->loc
));
189 /* Run check for missing location information. */
192 check_locus (gfc_namespace
*ns
)
194 gfc_code_walker (&ns
->code
, check_locus_code
, check_locus_expr
, NULL
);
196 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
198 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
205 /* Callback for each gfc_code node invoked from check_realloc_strings.
206 For an allocatable LHS string which also appears as a variable on
218 realloc_string_callback (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
219 void *data ATTRIBUTE_UNUSED
)
221 gfc_expr
*expr1
, *expr2
;
227 if (co
->op
!= EXEC_ASSIGN
)
231 if (expr1
->ts
.type
!= BT_CHARACTER
|| expr1
->rank
!= 0
232 || !gfc_expr_attr(expr1
).allocatable
233 || !expr1
->ts
.deferred
)
236 expr2
= gfc_discard_nops (co
->expr2
);
237 if (expr2
->expr_type
!= EXPR_VARIABLE
)
240 found_substr
= false;
241 for (ref
= expr2
->ref
; ref
; ref
= ref
->next
)
243 if (ref
->type
== REF_SUBSTRING
)
252 if (!gfc_check_dependency (expr1
, expr2
, true))
255 /* gfc_check_dependency doesn't always pick up identical expressions.
256 However, eliminating the above sends the compiler into an infinite
257 loop on valid expressions. Without this check, the gimplifier emits
258 an ICE for a = a, where a is deferred character length. */
259 if (!gfc_dep_compare_expr (expr1
, expr2
))
263 inserted_block
= NULL
;
264 changed_statement
= NULL
;
265 n
= create_var (expr2
, "realloc_string");
270 /* Callback for each gfc_code node invoked through gfc_code_walker
271 from optimize_namespace. */
274 optimize_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
275 void *data ATTRIBUTE_UNUSED
)
282 if (op
== EXEC_CALL
|| op
== EXEC_COMPCALL
|| op
== EXEC_ASSIGN_CALL
283 || op
== EXEC_CALL_PPC
)
289 inserted_block
= NULL
;
290 changed_statement
= NULL
;
292 if (op
== EXEC_ASSIGN
)
293 optimize_assignment (*c
);
297 /* Callback for each gfc_expr node invoked through gfc_code_walker
298 from optimize_namespace. */
301 optimize_expr (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
302 void *data ATTRIBUTE_UNUSED
)
306 if ((*e
)->expr_type
== EXPR_FUNCTION
)
309 function_expr
= true;
312 function_expr
= false;
314 if (optimize_trim (*e
))
315 gfc_simplify_expr (*e
, 0);
317 if (optimize_lexical_comparison (*e
))
318 gfc_simplify_expr (*e
, 0);
320 if ((*e
)->expr_type
== EXPR_OP
&& optimize_op (*e
))
321 gfc_simplify_expr (*e
, 0);
323 if ((*e
)->expr_type
== EXPR_FUNCTION
&& (*e
)->value
.function
.isym
)
324 switch ((*e
)->value
.function
.isym
->id
)
326 case GFC_ISYM_MINLOC
:
327 case GFC_ISYM_MAXLOC
:
328 optimize_minmaxloc (e
);
340 /* Auxiliary function to handle the arguments to reduction intrnisics. If the
341 function is a scalar, just copy it; otherwise returns the new element, the
342 old one can be freed. */
345 copy_walk_reduction_arg (gfc_constructor
*c
, gfc_expr
*fn
)
347 gfc_expr
*fcn
, *e
= c
->expr
;
349 fcn
= gfc_copy_expr (e
);
352 gfc_constructor_base newbase
;
354 gfc_constructor
*new_c
;
357 new_expr
= gfc_get_expr ();
358 new_expr
->expr_type
= EXPR_ARRAY
;
359 new_expr
->ts
= e
->ts
;
360 new_expr
->where
= e
->where
;
362 new_c
= gfc_constructor_append_expr (&newbase
, fcn
, &(e
->where
));
363 new_c
->iterator
= c
->iterator
;
364 new_expr
->value
.constructor
= newbase
;
372 gfc_isym_id id
= fn
->value
.function
.isym
->id
;
374 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
375 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
376 fn
->value
.function
.isym
->name
,
377 fn
->where
, 3, fcn
, NULL
, NULL
);
378 else if (id
== GFC_ISYM_ANY
|| id
== GFC_ISYM_ALL
)
379 fcn
= gfc_build_intrinsic_call (current_ns
, id
,
380 fn
->value
.function
.isym
->name
,
381 fn
->where
, 2, fcn
, NULL
);
383 gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
385 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
391 /* Callback function for optimzation of reductions to scalars. Transform ANY
392 ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
393 correspondingly. Handly only the simple cases without MASK and DIM. */
396 callback_reduction (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
397 void *data ATTRIBUTE_UNUSED
)
402 gfc_actual_arglist
*a
;
403 gfc_actual_arglist
*dim
;
405 gfc_expr
*res
, *new_expr
;
406 gfc_actual_arglist
*mask
;
410 if (fn
->rank
!= 0 || fn
->expr_type
!= EXPR_FUNCTION
411 || fn
->value
.function
.isym
== NULL
)
414 id
= fn
->value
.function
.isym
->id
;
416 if (id
!= GFC_ISYM_SUM
&& id
!= GFC_ISYM_PRODUCT
417 && id
!= GFC_ISYM_ANY
&& id
!= GFC_ISYM_ALL
)
420 a
= fn
->value
.function
.actual
;
422 /* Don't handle MASK or DIM. */
426 if (dim
->expr
!= NULL
)
429 if (id
== GFC_ISYM_SUM
|| id
== GFC_ISYM_PRODUCT
)
432 if ( mask
->expr
!= NULL
)
438 if (arg
->expr_type
!= EXPR_ARRAY
)
447 case GFC_ISYM_PRODUCT
:
448 op
= INTRINSIC_TIMES
;
463 c
= gfc_constructor_first (arg
->value
.constructor
);
465 /* Don't do any simplififcation if we have
466 - no element in the constructor or
467 - only have a single element in the array which contains an
473 res
= copy_walk_reduction_arg (c
, fn
);
475 c
= gfc_constructor_next (c
);
478 new_expr
= gfc_get_expr ();
479 new_expr
->ts
= fn
->ts
;
480 new_expr
->expr_type
= EXPR_OP
;
481 new_expr
->rank
= fn
->rank
;
482 new_expr
->where
= fn
->where
;
483 new_expr
->value
.op
.op
= op
;
484 new_expr
->value
.op
.op1
= res
;
485 new_expr
->value
.op
.op2
= copy_walk_reduction_arg (c
, fn
);
487 c
= gfc_constructor_next (c
);
490 gfc_simplify_expr (res
, 0);
497 /* Callback function for common function elimination, called from cfe_expr_0.
498 Put all eligible function expressions into expr_array. */
501 cfe_register_funcs (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
502 void *data ATTRIBUTE_UNUSED
)
505 if ((*e
)->expr_type
!= EXPR_FUNCTION
)
508 /* We don't do character functions with unknown charlens. */
509 if ((*e
)->ts
.type
== BT_CHARACTER
510 && ((*e
)->ts
.u
.cl
== NULL
|| (*e
)->ts
.u
.cl
->length
== NULL
511 || (*e
)->ts
.u
.cl
->length
->expr_type
!= EXPR_CONSTANT
))
514 /* We don't do function elimination within FORALL statements, it can
515 lead to wrong-code in certain circumstances. */
517 if (forall_level
> 0)
520 /* Function elimination inside an iterator could lead to functions which
521 depend on iterator variables being moved outside. FIXME: We should check
522 if the functions do indeed depend on the iterator variable. */
524 if (iterator_level
> 0)
527 /* If we don't know the shape at compile time, we create an allocatable
528 temporary variable to hold the intermediate result, but only if
529 allocation on assignment is active. */
531 if ((*e
)->rank
> 0 && (*e
)->shape
== NULL
&& !flag_realloc_lhs
)
534 /* Skip the test for pure functions if -faggressive-function-elimination
536 if ((*e
)->value
.function
.esym
)
538 /* Don't create an array temporary for elemental functions. */
539 if ((*e
)->value
.function
.esym
->attr
.elemental
&& (*e
)->rank
> 0)
542 /* Only eliminate potentially impure functions if the
543 user specifically requested it. */
544 if (!flag_aggressive_function_elimination
545 && !(*e
)->value
.function
.esym
->attr
.pure
546 && !(*e
)->value
.function
.esym
->attr
.implicit_pure
)
550 if ((*e
)->value
.function
.isym
)
552 /* Conversions are handled on the fly by the middle end,
553 transpose during trans-* stages and TRANSFER by the middle end. */
554 if ((*e
)->value
.function
.isym
->id
== GFC_ISYM_CONVERSION
555 || (*e
)->value
.function
.isym
->id
== GFC_ISYM_TRANSFER
556 || gfc_inline_intrinsic_function_p (*e
))
559 /* Don't create an array temporary for elemental functions,
560 as this would be wasteful of memory.
561 FIXME: Create a scalar temporary during scalarization. */
562 if ((*e
)->value
.function
.isym
->elemental
&& (*e
)->rank
> 0)
565 if (!(*e
)->value
.function
.isym
->pure
)
569 expr_array
.safe_push (e
);
573 /* Auxiliary function to check if an expression is a temporary created by
577 is_fe_temp (gfc_expr
*e
)
579 if (e
->expr_type
!= EXPR_VARIABLE
)
582 return e
->symtree
->n
.sym
->attr
.fe_temp
;
585 /* Determine the length of a string, if it can be evaluated as a constant
586 expression. Return a newly allocated gfc_expr or NULL on failure.
587 If the user specified a substring which is potentially longer than
588 the string itself, the string will be padded with spaces, which
592 constant_string_length (gfc_expr
*e
)
602 length
= e
->ts
.u
.cl
->length
;
603 if (length
&& length
->expr_type
== EXPR_CONSTANT
)
604 return gfc_copy_expr(length
);
607 /* Return length of substring, if constant. */
608 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
610 if (ref
->type
== REF_SUBSTRING
611 && gfc_dep_difference (ref
->u
.ss
.end
, ref
->u
.ss
.start
, &value
))
613 res
= gfc_get_constant_expr (BT_INTEGER
, gfc_charlen_int_kind
,
616 mpz_add_ui (res
->value
.integer
, value
, 1);
622 /* Return length of char symbol, if constant. */
624 if (e
->symtree
->n
.sym
->ts
.u
.cl
&& e
->symtree
->n
.sym
->ts
.u
.cl
->length
625 && e
->symtree
->n
.sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
)
626 return gfc_copy_expr (e
->symtree
->n
.sym
->ts
.u
.cl
->length
);
632 /* Insert a block at the current position unless it has already
633 been inserted; in this case use the one already there. */
635 static gfc_namespace
*
640 /* If the block hasn't already been created, do so. */
641 if (inserted_block
== NULL
)
643 inserted_block
= XCNEW (gfc_code
);
644 inserted_block
->op
= EXEC_BLOCK
;
645 inserted_block
->loc
= (*current_code
)->loc
;
646 ns
= gfc_build_block_ns (current_ns
);
647 inserted_block
->ext
.block
.ns
= ns
;
648 inserted_block
->ext
.block
.assoc
= NULL
;
650 ns
->code
= *current_code
;
652 /* If the statement has a label, make sure it is transferred to
653 the newly created block. */
655 if ((*current_code
)->here
)
657 inserted_block
->here
= (*current_code
)->here
;
658 (*current_code
)->here
= NULL
;
661 inserted_block
->next
= (*current_code
)->next
;
662 changed_statement
= &(inserted_block
->ext
.block
.ns
->code
);
663 (*current_code
)->next
= NULL
;
664 /* Insert the BLOCK at the right position. */
665 *current_code
= inserted_block
;
666 ns
->parent
= current_ns
;
669 ns
= inserted_block
->ext
.block
.ns
;
674 /* Returns a new expression (a variable) to be used in place of the old one,
675 with an optional assignment statement before the current statement to set
676 the value of the variable. Creates a new BLOCK for the statement if that
677 hasn't already been done and puts the statement, plus the newly created
678 variables, in that block. Special cases: If the expression is constant or
679 a temporary which has already been created, just copy it. */
682 create_var (gfc_expr
* e
, const char *vname
)
684 char name
[GFC_MAX_SYMBOL_LEN
+1];
685 gfc_symtree
*symtree
;
693 if (e
->expr_type
== EXPR_CONSTANT
|| is_fe_temp (e
))
694 return gfc_copy_expr (e
);
696 ns
= insert_block ();
699 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d_%s", var_num
++, vname
);
701 snprintf (name
, GFC_MAX_SYMBOL_LEN
, "__var_%d", var_num
++);
703 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
706 symbol
= symtree
->n
.sym
;
711 symbol
->as
= gfc_get_array_spec ();
712 symbol
->as
->rank
= e
->rank
;
714 if (e
->shape
== NULL
)
716 /* We don't know the shape at compile time, so we use an
718 symbol
->as
->type
= AS_DEFERRED
;
719 symbol
->attr
.allocatable
= 1;
723 symbol
->as
->type
= AS_EXPLICIT
;
724 /* Copy the shape. */
725 for (i
=0; i
<e
->rank
; i
++)
729 p
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
731 mpz_set_si (p
->value
.integer
, 1);
732 symbol
->as
->lower
[i
] = p
;
734 q
= gfc_get_constant_expr (BT_INTEGER
, gfc_index_integer_kind
,
736 mpz_set (q
->value
.integer
, e
->shape
[i
]);
737 symbol
->as
->upper
[i
] = q
;
743 if (e
->ts
.type
== BT_CHARACTER
&& e
->rank
== 0)
747 symbol
->ts
.u
.cl
= gfc_new_charlen (ns
, NULL
);
748 length
= constant_string_length (e
);
750 symbol
->ts
.u
.cl
->length
= length
;
753 symbol
->attr
.allocatable
= 1;
758 symbol
->attr
.flavor
= FL_VARIABLE
;
759 symbol
->attr
.referenced
= 1;
760 symbol
->attr
.dimension
= e
->rank
> 0;
761 symbol
->attr
.fe_temp
= 1;
762 gfc_commit_symbol (symbol
);
764 result
= gfc_get_expr ();
765 result
->expr_type
= EXPR_VARIABLE
;
767 result
->ts
.deferred
= deferred
;
768 result
->rank
= e
->rank
;
769 result
->shape
= gfc_copy_shape (e
->shape
, e
->rank
);
770 result
->symtree
= symtree
;
771 result
->where
= e
->where
;
774 result
->ref
= gfc_get_ref ();
775 result
->ref
->type
= REF_ARRAY
;
776 result
->ref
->u
.ar
.type
= AR_FULL
;
777 result
->ref
->u
.ar
.where
= e
->where
;
778 result
->ref
->u
.ar
.dimen
= e
->rank
;
779 result
->ref
->u
.ar
.as
= symbol
->ts
.type
== BT_CLASS
780 ? CLASS_DATA (symbol
)->as
: symbol
->as
;
781 if (warn_array_temporaries
)
782 gfc_warning (OPT_Warray_temporaries
,
783 "Creating array temporary at %L", &(e
->where
));
786 /* Generate the new assignment. */
787 n
= XCNEW (gfc_code
);
789 n
->loc
= (*current_code
)->loc
;
790 n
->next
= *changed_statement
;
791 n
->expr1
= gfc_copy_expr (result
);
793 *changed_statement
= n
;
799 /* Warn about function elimination. */
802 do_warn_function_elimination (gfc_expr
*e
)
804 if (e
->expr_type
!= EXPR_FUNCTION
)
806 if (e
->value
.function
.esym
)
807 gfc_warning (OPT_Wfunction_elimination
,
808 "Removing call to function %qs at %L",
809 e
->value
.function
.esym
->name
, &(e
->where
));
810 else if (e
->value
.function
.isym
)
811 gfc_warning (OPT_Wfunction_elimination
,
812 "Removing call to function %qs at %L",
813 e
->value
.function
.isym
->name
, &(e
->where
));
815 /* Callback function for the code walker for doing common function
816 elimination. This builds up the list of functions in the expression
817 and goes through them to detect duplicates, which it then replaces
821 cfe_expr_0 (gfc_expr
**e
, int *walk_subtrees
,
822 void *data ATTRIBUTE_UNUSED
)
828 /* Don't do this optimization within OMP workshare or ASSOC lists. */
830 if (in_omp_workshare
|| in_assoc_list
)
836 expr_array
.release ();
838 gfc_expr_walker (e
, cfe_register_funcs
, NULL
);
840 /* Walk through all the functions. */
842 FOR_EACH_VEC_ELT_FROM (expr_array
, i
, ei
, 1)
844 /* Skip if the function has been replaced by a variable already. */
845 if ((*ei
)->expr_type
== EXPR_VARIABLE
)
852 if (gfc_dep_compare_functions (*ei
, *ej
, true) == 0)
855 newvar
= create_var (*ei
, "fcn");
857 if (warn_function_elimination
)
858 do_warn_function_elimination (*ej
);
861 *ej
= gfc_copy_expr (newvar
);
868 /* We did all the necessary walking in this function. */
873 /* Callback function for common function elimination, called from
874 gfc_code_walker. This keeps track of the current code, in order
875 to insert statements as needed. */
878 cfe_code (gfc_code
**c
, int *walk_subtrees
, void *data ATTRIBUTE_UNUSED
)
881 inserted_block
= NULL
;
882 changed_statement
= NULL
;
884 /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
885 and allocation on assigment are prohibited inside WHERE, and finally
886 masking an expression would lead to wrong-code when replacing
889 b = sum(foo(a) + foo(a))
900 if ((*c
)->op
== EXEC_WHERE
)
910 /* Dummy function for expression call back, for use when we
911 really don't want to do any walking. */
914 dummy_expr_callback (gfc_expr
**e ATTRIBUTE_UNUSED
, int *walk_subtrees
,
915 void *data ATTRIBUTE_UNUSED
)
921 /* Dummy function for code callback, for use when we really
922 don't want to do anything. */
924 gfc_dummy_code_callback (gfc_code
**e ATTRIBUTE_UNUSED
,
925 int *walk_subtrees ATTRIBUTE_UNUSED
,
926 void *data ATTRIBUTE_UNUSED
)
931 /* Code callback function for converting
938 This is because common function elimination would otherwise place the
939 temporary variables outside the loop. */
942 convert_do_while (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
943 void *data ATTRIBUTE_UNUSED
)
946 gfc_code
*c_if1
, *c_if2
, *c_exit
;
948 gfc_expr
*e_not
, *e_cond
;
950 if (co
->op
!= EXEC_DO_WHILE
)
953 if (co
->expr1
== NULL
|| co
->expr1
->expr_type
== EXPR_CONSTANT
)
958 /* Generate the condition of the if statement, which is .not. the original
960 e_not
= gfc_get_expr ();
961 e_not
->ts
= e_cond
->ts
;
962 e_not
->where
= e_cond
->where
;
963 e_not
->expr_type
= EXPR_OP
;
964 e_not
->value
.op
.op
= INTRINSIC_NOT
;
965 e_not
->value
.op
.op1
= e_cond
;
967 /* Generate the EXIT statement. */
968 c_exit
= XCNEW (gfc_code
);
969 c_exit
->op
= EXEC_EXIT
;
970 c_exit
->ext
.which_construct
= co
;
971 c_exit
->loc
= co
->loc
;
973 /* Generate the IF statement. */
974 c_if2
= XCNEW (gfc_code
);
976 c_if2
->expr1
= e_not
;
977 c_if2
->next
= c_exit
;
978 c_if2
->loc
= co
->loc
;
980 /* ... plus the one to chain it to. */
981 c_if1
= XCNEW (gfc_code
);
983 c_if1
->block
= c_if2
;
984 c_if1
->loc
= co
->loc
;
986 /* Make the DO WHILE loop into a DO block by replacing the condition
987 with a true constant. */
988 co
->expr1
= gfc_get_logical_expr (gfc_default_integer_kind
, &co
->loc
, true);
990 /* Hang the generated if statement into the loop body. */
992 loopblock
= co
->block
->next
;
993 co
->block
->next
= c_if1
;
994 c_if1
->next
= loopblock
;
999 /* Code callback function for converting
1012 because otherwise common function elimination would place the BLOCKs
1013 into the wrong place. */
1016 convert_elseif (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1017 void *data ATTRIBUTE_UNUSED
)
1020 gfc_code
*c_if1
, *c_if2
, *else_stmt
;
1022 if (co
->op
!= EXEC_IF
)
1025 /* This loop starts out with the first ELSE statement. */
1026 else_stmt
= co
->block
->block
;
1028 while (else_stmt
!= NULL
)
1030 gfc_code
*next_else
;
1032 /* If there is no condition, we're done. */
1033 if (else_stmt
->expr1
== NULL
)
1036 next_else
= else_stmt
->block
;
1038 /* Generate the new IF statement. */
1039 c_if2
= XCNEW (gfc_code
);
1040 c_if2
->op
= EXEC_IF
;
1041 c_if2
->expr1
= else_stmt
->expr1
;
1042 c_if2
->next
= else_stmt
->next
;
1043 c_if2
->loc
= else_stmt
->loc
;
1044 c_if2
->block
= next_else
;
1046 /* ... plus the one to chain it to. */
1047 c_if1
= XCNEW (gfc_code
);
1048 c_if1
->op
= EXEC_IF
;
1049 c_if1
->block
= c_if2
;
1050 c_if1
->loc
= else_stmt
->loc
;
1052 /* Insert the new IF after the ELSE. */
1053 else_stmt
->expr1
= NULL
;
1054 else_stmt
->next
= c_if1
;
1055 else_stmt
->block
= NULL
;
1057 else_stmt
= next_else
;
1059 /* Don't walk subtrees. */
1063 /* Optimize a namespace, including all contained namespaces. */
1066 optimize_namespace (gfc_namespace
*ns
)
1068 gfc_namespace
*saved_ns
= gfc_current_ns
;
1070 gfc_current_ns
= ns
;
1073 in_assoc_list
= false;
1074 in_omp_workshare
= false;
1076 gfc_code_walker (&ns
->code
, convert_do_while
, dummy_expr_callback
, NULL
);
1077 gfc_code_walker (&ns
->code
, convert_elseif
, dummy_expr_callback
, NULL
);
1078 gfc_code_walker (&ns
->code
, cfe_code
, cfe_expr_0
, NULL
);
1079 gfc_code_walker (&ns
->code
, optimize_code
, optimize_expr
, NULL
);
1080 if (flag_inline_matmul_limit
!= 0)
1086 gfc_code_walker (&ns
->code
, matmul_to_var_code
, matmul_to_var_expr
,
1091 gfc_code_walker (&ns
->code
, inline_matmul_assign
, dummy_expr_callback
,
1095 /* BLOCKs are handled in the expression walker below. */
1096 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1098 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1099 optimize_namespace (ns
);
1101 gfc_current_ns
= saved_ns
;
1104 /* Handle dependencies for allocatable strings which potentially redefine
1105 themselves in an assignment. */
1108 realloc_strings (gfc_namespace
*ns
)
1111 gfc_code_walker (&ns
->code
, realloc_string_callback
, dummy_expr_callback
, NULL
);
1113 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1115 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1116 realloc_strings (ns
);
1122 optimize_reduction (gfc_namespace
*ns
)
1125 gfc_code_walker (&ns
->code
, gfc_dummy_code_callback
,
1126 callback_reduction
, NULL
);
1128 /* BLOCKs are handled in the expression walker below. */
1129 for (ns
= ns
->contained
; ns
; ns
= ns
->sibling
)
1131 if (ns
->code
== NULL
|| ns
->code
->op
!= EXEC_BLOCK
)
1132 optimize_reduction (ns
);
1136 /* Replace code like
1139 a = matmul(b,c) ; a = a + d
1140 where the array function is not elemental and not allocatable
1141 and does not depend on the left-hand side.
1145 optimize_binop_array_assignment (gfc_code
*c
, gfc_expr
**rhs
, bool seen_op
)
1153 if (e
->expr_type
== EXPR_OP
)
1155 switch (e
->value
.op
.op
)
1157 /* Unary operators and exponentiation: Only look at a single
1160 case INTRINSIC_UPLUS
:
1161 case INTRINSIC_UMINUS
:
1162 case INTRINSIC_PARENTHESES
:
1163 case INTRINSIC_POWER
:
1164 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, seen_op
))
1168 case INTRINSIC_CONCAT
:
1169 /* Do not do string concatenations. */
1173 /* Binary operators. */
1174 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op1
, true))
1177 if (optimize_binop_array_assignment (c
, &e
->value
.op
.op2
, true))
1183 else if (seen_op
&& e
->expr_type
== EXPR_FUNCTION
&& e
->rank
> 0
1184 && ! (e
->value
.function
.esym
1185 && (e
->value
.function
.esym
->attr
.elemental
1186 || e
->value
.function
.esym
->attr
.allocatable
1187 || e
->value
.function
.esym
->ts
.type
!= c
->expr1
->ts
.type
1188 || e
->value
.function
.esym
->ts
.kind
!= c
->expr1
->ts
.kind
))
1189 && ! (e
->value
.function
.isym
1190 && (e
->value
.function
.isym
->elemental
1191 || e
->ts
.type
!= c
->expr1
->ts
.type
1192 || e
->ts
.kind
!= c
->expr1
->ts
.kind
))
1193 && ! gfc_inline_intrinsic_function_p (e
))
1199 /* Insert a new assignment statement after the current one. */
1200 n
= XCNEW (gfc_code
);
1201 n
->op
= EXEC_ASSIGN
;
1206 n
->expr1
= gfc_copy_expr (c
->expr1
);
1207 n
->expr2
= c
->expr2
;
1208 new_expr
= gfc_copy_expr (c
->expr1
);
1216 /* Nothing to optimize. */
1220 /* Remove unneeded TRIMs at the end of expressions. */
1223 remove_trim (gfc_expr
*rhs
)
1231 /* Check for a // b // trim(c). Looping is probably not
1232 necessary because the parser usually generates
1233 (// (// a b ) trim(c) ) , but better safe than sorry. */
1235 while (rhs
->expr_type
== EXPR_OP
1236 && rhs
->value
.op
.op
== INTRINSIC_CONCAT
)
1237 rhs
= rhs
->value
.op
.op2
;
1239 while (rhs
->expr_type
== EXPR_FUNCTION
&& rhs
->value
.function
.isym
1240 && rhs
->value
.function
.isym
->id
== GFC_ISYM_TRIM
)
1242 strip_function_call (rhs
);
1243 /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
1251 /* Optimizations for an assignment. */
1254 optimize_assignment (gfc_code
* c
)
1256 gfc_expr
*lhs
, *rhs
;
1261 if (lhs
->ts
.type
== BT_CHARACTER
&& !lhs
->ts
.deferred
)
1263 /* Optimize a = trim(b) to a = b. */
1266 /* Replace a = ' ' by a = '' to optimize away a memcpy. */
1267 if (is_empty_string (rhs
))
1268 rhs
->value
.character
.length
= 0;
1271 if (lhs
->rank
> 0 && gfc_check_dependency (lhs
, rhs
, true) == 0)
1272 optimize_binop_array_assignment (c
, &rhs
, false);
1276 /* Remove an unneeded function call, modifying the expression.
1277 This replaces the function call with the value of its
1278 first argument. The rest of the argument list is freed. */
1281 strip_function_call (gfc_expr
*e
)
1284 gfc_actual_arglist
*a
;
1286 a
= e
->value
.function
.actual
;
1288 /* We should have at least one argument. */
1289 gcc_assert (a
->expr
!= NULL
);
1293 /* Free the remaining arglist, if any. */
1295 gfc_free_actual_arglist (a
->next
);
1297 /* Graft the argument expression onto the original function. */
1303 /* Optimization of lexical comparison functions. */
1306 optimize_lexical_comparison (gfc_expr
*e
)
1308 if (e
->expr_type
!= EXPR_FUNCTION
|| e
->value
.function
.isym
== NULL
)
1311 switch (e
->value
.function
.isym
->id
)
1314 return optimize_comparison (e
, INTRINSIC_LE
);
1317 return optimize_comparison (e
, INTRINSIC_GE
);
1320 return optimize_comparison (e
, INTRINSIC_GT
);
1323 return optimize_comparison (e
, INTRINSIC_LT
);
1331 /* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
1332 do CHARACTER because of possible pessimization involving character
1336 combine_array_constructor (gfc_expr
*e
)
1339 gfc_expr
*op1
, *op2
;
1342 gfc_constructor
*c
, *new_c
;
1343 gfc_constructor_base oldbase
, newbase
;
1346 /* Array constructors have rank one. */
1350 /* Don't try to combine association lists, this makes no sense
1351 and leads to an ICE. */
1355 /* With FORALL, the BLOCKS created by create_var will cause an ICE. */
1356 if (forall_level
> 0)
1359 /* Inside an iterator, things can get hairy; we are likely to create
1360 an invalid temporary variable. */
1361 if (iterator_level
> 0)
1364 op1
= e
->value
.op
.op1
;
1365 op2
= e
->value
.op
.op2
;
1370 if (op1
->expr_type
== EXPR_ARRAY
&& op2
->rank
== 0)
1371 scalar_first
= false;
1372 else if (op2
->expr_type
== EXPR_ARRAY
&& op1
->rank
== 0)
1374 scalar_first
= true;
1375 op1
= e
->value
.op
.op2
;
1376 op2
= e
->value
.op
.op1
;
1381 if (op2
->ts
.type
== BT_CHARACTER
)
1384 scalar
= create_var (gfc_copy_expr (op2
), "constr");
1386 oldbase
= op1
->value
.constructor
;
1388 e
->expr_type
= EXPR_ARRAY
;
1390 for (c
= gfc_constructor_first (oldbase
); c
;
1391 c
= gfc_constructor_next (c
))
1393 new_expr
= gfc_get_expr ();
1394 new_expr
->ts
= e
->ts
;
1395 new_expr
->expr_type
= EXPR_OP
;
1396 new_expr
->rank
= c
->expr
->rank
;
1397 new_expr
->where
= c
->expr
->where
;
1398 new_expr
->value
.op
.op
= e
->value
.op
.op
;
1402 new_expr
->value
.op
.op1
= gfc_copy_expr (scalar
);
1403 new_expr
->value
.op
.op2
= gfc_copy_expr (c
->expr
);
1407 new_expr
->value
.op
.op1
= gfc_copy_expr (c
->expr
);
1408 new_expr
->value
.op
.op2
= gfc_copy_expr (scalar
);
1411 new_c
= gfc_constructor_append_expr (&newbase
, new_expr
, &(e
->where
));
1412 new_c
->iterator
= c
->iterator
;
1416 gfc_free_expr (op1
);
1417 gfc_free_expr (op2
);
1418 gfc_free_expr (scalar
);
1420 e
->value
.constructor
= newbase
;
1424 /* Change (-1)**k into 1-ishift(iand(k,1),1) and
1425 2**k into ishift(1,k) */
1428 optimize_power (gfc_expr
*e
)
1430 gfc_expr
*op1
, *op2
;
1431 gfc_expr
*iand
, *ishft
;
1433 if (e
->ts
.type
!= BT_INTEGER
)
1436 op1
= e
->value
.op
.op1
;
1438 if (op1
== NULL
|| op1
->expr_type
!= EXPR_CONSTANT
)
1441 if (mpz_cmp_si (op1
->value
.integer
, -1L) == 0)
1443 gfc_free_expr (op1
);
1445 op2
= e
->value
.op
.op2
;
1450 iand
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_IAND
,
1451 "_internal_iand", e
->where
, 2, op2
,
1452 gfc_get_int_expr (e
->ts
.kind
,
1455 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1456 "_internal_ishft", e
->where
, 2, iand
,
1457 gfc_get_int_expr (e
->ts
.kind
,
1460 e
->value
.op
.op
= INTRINSIC_MINUS
;
1461 e
->value
.op
.op1
= gfc_get_int_expr (e
->ts
.kind
, &e
->where
, 1);
1462 e
->value
.op
.op2
= ishft
;
1465 else if (mpz_cmp_si (op1
->value
.integer
, 2L) == 0)
1467 gfc_free_expr (op1
);
1469 op2
= e
->value
.op
.op2
;
1473 ishft
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ISHFT
,
1474 "_internal_ishft", e
->where
, 2,
1475 gfc_get_int_expr (e
->ts
.kind
,
1482 else if (mpz_cmp_si (op1
->value
.integer
, 1L) == 0)
1484 op2
= e
->value
.op
.op2
;
1488 gfc_free_expr (op1
);
1489 gfc_free_expr (op2
);
1491 e
->expr_type
= EXPR_CONSTANT
;
1492 e
->value
.op
.op1
= NULL
;
1493 e
->value
.op
.op2
= NULL
;
1494 mpz_init_set_si (e
->value
.integer
, 1);
1495 /* Typespec and location are still OK. */
1502 /* Recursive optimization of operators. */
1505 optimize_op (gfc_expr
*e
)
1509 gfc_intrinsic_op op
= e
->value
.op
.op
;
1513 /* Only use new-style comparisons. */
1516 case INTRINSIC_EQ_OS
:
1520 case INTRINSIC_GE_OS
:
1524 case INTRINSIC_LE_OS
:
1528 case INTRINSIC_NE_OS
:
1532 case INTRINSIC_GT_OS
:
1536 case INTRINSIC_LT_OS
:
1552 changed
= optimize_comparison (e
, op
);
1555 /* Look at array constructors. */
1556 case INTRINSIC_PLUS
:
1557 case INTRINSIC_MINUS
:
1558 case INTRINSIC_TIMES
:
1559 case INTRINSIC_DIVIDE
:
1560 return combine_array_constructor (e
) || changed
;
1562 case INTRINSIC_POWER
:
1563 return optimize_power (e
);
1573 /* Return true if a constant string contains only blanks. */
1576 is_empty_string (gfc_expr
*e
)
1580 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1583 for (i
=0; i
< e
->value
.character
.length
; i
++)
1585 if (e
->value
.character
.string
[i
] != ' ')
1593 /* Insert a call to the intrinsic len_trim. Use a different name for
1594 the symbol tree so we don't run into trouble when the user has
1595 renamed len_trim for some reason. */
1598 get_len_trim_call (gfc_expr
*str
, int kind
)
1601 gfc_actual_arglist
*actual_arglist
, *next
;
1603 fcn
= gfc_get_expr ();
1604 fcn
->expr_type
= EXPR_FUNCTION
;
1605 fcn
->value
.function
.isym
= gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM
);
1606 actual_arglist
= gfc_get_actual_arglist ();
1607 actual_arglist
->expr
= str
;
1608 next
= gfc_get_actual_arglist ();
1609 next
->expr
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, kind
);
1610 actual_arglist
->next
= next
;
1612 fcn
->value
.function
.actual
= actual_arglist
;
1613 fcn
->where
= str
->where
;
1614 fcn
->ts
.type
= BT_INTEGER
;
1615 fcn
->ts
.kind
= gfc_charlen_int_kind
;
1617 gfc_get_sym_tree ("__internal_len_trim", current_ns
, &fcn
->symtree
, false);
1618 fcn
->symtree
->n
.sym
->ts
= fcn
->ts
;
1619 fcn
->symtree
->n
.sym
->attr
.flavor
= FL_PROCEDURE
;
1620 fcn
->symtree
->n
.sym
->attr
.function
= 1;
1621 fcn
->symtree
->n
.sym
->attr
.elemental
= 1;
1622 fcn
->symtree
->n
.sym
->attr
.referenced
= 1;
1623 fcn
->symtree
->n
.sym
->attr
.access
= ACCESS_PRIVATE
;
1624 gfc_commit_symbol (fcn
->symtree
->n
.sym
);
1629 /* Optimize expressions for equality. */
1632 optimize_comparison (gfc_expr
*e
, gfc_intrinsic_op op
)
1634 gfc_expr
*op1
, *op2
;
1638 gfc_actual_arglist
*firstarg
, *secondarg
;
1640 if (e
->expr_type
== EXPR_OP
)
1644 op1
= e
->value
.op
.op1
;
1645 op2
= e
->value
.op
.op2
;
1647 else if (e
->expr_type
== EXPR_FUNCTION
)
1649 /* One of the lexical comparison functions. */
1650 firstarg
= e
->value
.function
.actual
;
1651 secondarg
= firstarg
->next
;
1652 op1
= firstarg
->expr
;
1653 op2
= secondarg
->expr
;
1658 /* Strip off unneeded TRIM calls from string comparisons. */
1660 change
= remove_trim (op1
);
1662 if (remove_trim (op2
))
1665 /* An expression of type EXPR_CONSTANT is only valid for scalars. */
1666 /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
1667 handles them well). However, there are also cases that need a non-scalar
1668 argument. For example the any intrinsic. See PR 45380. */
1672 /* Replace a == '' with len_trim(a) == 0 and a /= '' with
1674 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1675 && (op
== INTRINSIC_EQ
|| op
== INTRINSIC_NE
))
1677 bool empty_op1
, empty_op2
;
1678 empty_op1
= is_empty_string (op1
);
1679 empty_op2
= is_empty_string (op2
);
1681 if (empty_op1
|| empty_op2
)
1687 /* This can only happen when an error for comparing
1688 characters of different kinds has already been issued. */
1689 if (empty_op1
&& empty_op2
)
1692 zero
= gfc_get_int_expr (gfc_charlen_int_kind
, &e
->where
, 0);
1693 str
= empty_op1
? op2
: op1
;
1695 fcn
= get_len_trim_call (str
, gfc_charlen_int_kind
);
1699 gfc_free_expr (op1
);
1701 gfc_free_expr (op2
);
1705 e
->value
.op
.op1
= fcn
;
1706 e
->value
.op
.op2
= zero
;
1711 /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
1713 if (flag_finite_math_only
1714 || (op1
->ts
.type
!= BT_REAL
&& op2
->ts
.type
!= BT_REAL
1715 && op1
->ts
.type
!= BT_COMPLEX
&& op2
->ts
.type
!= BT_COMPLEX
))
1717 eq
= gfc_dep_compare_expr (op1
, op2
);
1720 /* Replace A // B < A // C with B < C, and A // B < C // B
1722 if (op1
->ts
.type
== BT_CHARACTER
&& op2
->ts
.type
== BT_CHARACTER
1723 && op1
->expr_type
== EXPR_OP
1724 && op1
->value
.op
.op
== INTRINSIC_CONCAT
1725 && op2
->expr_type
== EXPR_OP
1726 && op2
->value
.op
.op
== INTRINSIC_CONCAT
)
1728 gfc_expr
*op1_left
= op1
->value
.op
.op1
;
1729 gfc_expr
*op2_left
= op2
->value
.op
.op1
;
1730 gfc_expr
*op1_right
= op1
->value
.op
.op2
;
1731 gfc_expr
*op2_right
= op2
->value
.op
.op2
;
1733 if (gfc_dep_compare_expr (op1_left
, op2_left
) == 0)
1735 /* Watch out for 'A ' // x vs. 'A' // x. */
1737 if (op1_left
->expr_type
== EXPR_CONSTANT
1738 && op2_left
->expr_type
== EXPR_CONSTANT
1739 && op1_left
->value
.character
.length
1740 != op2_left
->value
.character
.length
)
1748 firstarg
->expr
= op1_right
;
1749 secondarg
->expr
= op2_right
;
1753 e
->value
.op
.op1
= op1_right
;
1754 e
->value
.op
.op2
= op2_right
;
1756 optimize_comparison (e
, op
);
1760 if (gfc_dep_compare_expr (op1_right
, op2_right
) == 0)
1766 firstarg
->expr
= op1_left
;
1767 secondarg
->expr
= op2_left
;
1771 e
->value
.op
.op1
= op1_left
;
1772 e
->value
.op
.op2
= op2_left
;
1775 optimize_comparison (e
, op
);
1782 /* eq can only be -1, 0 or 1 at this point. */
1810 gfc_internal_error ("illegal OP in optimize_comparison");
1814 /* Replace the expression by a constant expression. The typespec
1815 and where remains the way it is. */
1818 e
->expr_type
= EXPR_CONSTANT
;
1819 e
->value
.logical
= result
;
1827 /* Optimize a trim function by replacing it with an equivalent substring
1828 involving a call to len_trim. This only works for expressions where
1829 variables are trimmed. Return true if anything was modified. */
1832 optimize_trim (gfc_expr
*e
)
1837 gfc_ref
**rr
= NULL
;
1839 /* Don't do this optimization within an argument list, because
1840 otherwise aliasing issues may occur. */
1842 if (count_arglist
!= 1)
1845 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_FUNCTION
1846 || e
->value
.function
.isym
== NULL
1847 || e
->value
.function
.isym
->id
!= GFC_ISYM_TRIM
)
1850 a
= e
->value
.function
.actual
->expr
;
1852 if (a
->expr_type
!= EXPR_VARIABLE
)
1855 /* This would pessimize the idiom a = trim(a) for reallocatable strings. */
1857 if (a
->symtree
->n
.sym
->attr
.allocatable
)
1860 /* Follow all references to find the correct place to put the newly
1861 created reference. FIXME: Also handle substring references and
1862 array references. Array references cause strange regressions at
1867 for (rr
= &(a
->ref
); *rr
; rr
= &((*rr
)->next
))
1869 if ((*rr
)->type
== REF_SUBSTRING
|| (*rr
)->type
== REF_ARRAY
)
1874 strip_function_call (e
);
1879 /* Create the reference. */
1881 ref
= gfc_get_ref ();
1882 ref
->type
= REF_SUBSTRING
;
1884 /* Set the start of the reference. */
1886 ref
->u
.ss
.start
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
1888 /* Build the function call to len_trim(x, gfc_default_integer_kind). */
1890 fcn
= get_len_trim_call (gfc_copy_expr (e
), gfc_default_integer_kind
);
1892 /* Set the end of the reference to the call to len_trim. */
1894 ref
->u
.ss
.end
= fcn
;
1895 gcc_assert (rr
!= NULL
&& *rr
== NULL
);
1900 /* Optimize minloc(b), where b is rank 1 array, into
1901 (/ minloc(b, dim=1) /), and similarly for maxloc,
1902 as the latter forms are expanded inline. */
1905 optimize_minmaxloc (gfc_expr
**e
)
1908 gfc_actual_arglist
*a
;
1912 || fn
->value
.function
.actual
== NULL
1913 || fn
->value
.function
.actual
->expr
== NULL
1914 || fn
->value
.function
.actual
->expr
->rank
!= 1)
1917 *e
= gfc_get_array_expr (fn
->ts
.type
, fn
->ts
.kind
, &fn
->where
);
1918 (*e
)->shape
= fn
->shape
;
1921 gfc_constructor_append_expr (&(*e
)->value
.constructor
, fn
, &fn
->where
);
1923 name
= XALLOCAVEC (char, strlen (fn
->value
.function
.name
) + 1);
1924 strcpy (name
, fn
->value
.function
.name
);
1925 p
= strstr (name
, "loc0");
1927 fn
->value
.function
.name
= gfc_get_string ("%s", name
);
1928 if (fn
->value
.function
.actual
->next
)
1930 a
= fn
->value
.function
.actual
->next
;
1931 gcc_assert (a
->expr
== NULL
);
1935 a
= gfc_get_actual_arglist ();
1936 fn
->value
.function
.actual
->next
= a
;
1938 a
->expr
= gfc_get_constant_expr (BT_INTEGER
, gfc_default_integer_kind
,
1940 mpz_set_ui (a
->expr
->value
.integer
, 1);
1943 /* Callback function for code checking that we do not pass a DO variable to an
1944 INTENT(OUT) or INTENT(INOUT) dummy variable. */
1947 doloop_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
1948 void *data ATTRIBUTE_UNUSED
)
1952 gfc_formal_arglist
*f
;
1953 gfc_actual_arglist
*a
;
1958 /* If the doloop_list grew, we have to truncate it here. */
1960 if ((unsigned) doloop_level
< doloop_list
.length())
1961 doloop_list
.truncate (doloop_level
);
1967 if (co
->ext
.iterator
&& co
->ext
.iterator
->var
)
1968 doloop_list
.safe_push (co
);
1970 doloop_list
.safe_push ((gfc_code
*) NULL
);
1975 if (co
->resolved_sym
== NULL
)
1978 f
= gfc_sym_get_dummy_args (co
->resolved_sym
);
1980 /* Withot a formal arglist, there is only unknown INTENT,
1981 which we don't check for. */
1989 FOR_EACH_VEC_ELT (doloop_list
, i
, cl
)
1996 do_sym
= cl
->ext
.iterator
->var
->symtree
->n
.sym
;
1998 if (a
->expr
&& a
->expr
->symtree
1999 && a
->expr
->symtree
->n
.sym
== do_sym
)
2001 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2002 gfc_error_now ("Variable %qs at %L set to undefined "
2003 "value inside loop beginning at %L as "
2004 "INTENT(OUT) argument to subroutine %qs",
2005 do_sym
->name
, &a
->expr
->where
,
2006 &doloop_list
[i
]->loc
,
2007 co
->symtree
->n
.sym
->name
);
2008 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2009 gfc_error_now ("Variable %qs at %L not definable inside "
2010 "loop beginning at %L as INTENT(INOUT) "
2011 "argument to subroutine %qs",
2012 do_sym
->name
, &a
->expr
->where
,
2013 &doloop_list
[i
]->loc
,
2014 co
->symtree
->n
.sym
->name
);
2028 /* Callback function for functions checking that we do not pass a DO variable
2029 to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
2032 do_function (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2033 void *data ATTRIBUTE_UNUSED
)
2035 gfc_formal_arglist
*f
;
2036 gfc_actual_arglist
*a
;
2042 if (expr
->expr_type
!= EXPR_FUNCTION
)
2045 /* Intrinsic functions don't modify their arguments. */
2047 if (expr
->value
.function
.isym
)
2050 f
= gfc_sym_get_dummy_args (expr
->symtree
->n
.sym
);
2052 /* Without a formal arglist, there is only unknown INTENT,
2053 which we don't check for. */
2057 a
= expr
->value
.function
.actual
;
2061 FOR_EACH_VEC_ELT (doloop_list
, i
, dl
)
2068 do_sym
= dl
->ext
.iterator
->var
->symtree
->n
.sym
;
2070 if (a
->expr
&& a
->expr
->symtree
2071 && a
->expr
->symtree
->n
.sym
== do_sym
)
2073 if (f
->sym
->attr
.intent
== INTENT_OUT
)
2074 gfc_error_now ("Variable %qs at %L set to undefined value "
2075 "inside loop beginning at %L as INTENT(OUT) "
2076 "argument to function %qs", do_sym
->name
,
2077 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2078 expr
->symtree
->n
.sym
->name
);
2079 else if (f
->sym
->attr
.intent
== INTENT_INOUT
)
2080 gfc_error_now ("Variable %qs at %L not definable inside loop"
2081 " beginning at %L as INTENT(INOUT) argument to"
2082 " function %qs", do_sym
->name
,
2083 &a
->expr
->where
, &doloop_list
[i
]->loc
,
2084 expr
->symtree
->n
.sym
->name
);
2095 doloop_warn (gfc_namespace
*ns
)
2097 gfc_code_walker (&ns
->code
, doloop_code
, do_function
, NULL
);
2100 /* This selction deals with inlining calls to MATMUL. */
2102 /* Replace calls to matmul outside of straight assignments with a temporary
2103 variable so that later inlining will work. */
2106 matmul_to_var_expr (gfc_expr
**ep
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2110 bool *found
= (bool *) data
;
2114 if (e
->expr_type
!= EXPR_FUNCTION
2115 || e
->value
.function
.isym
== NULL
2116 || e
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
2119 if (forall_level
> 0 || iterator_level
> 0 || in_omp_workshare
2123 /* Check if this is already in the form c = matmul(a,b). */
2125 if ((*current_code
)->expr2
== e
)
2128 n
= create_var (e
, "matmul");
2130 /* If create_var is unable to create a variable (for example if
2131 -fno-realloc-lhs is in force with a variable that does not have bounds
2132 known at compile-time), just return. */
2142 /* Set current_code and associated variables so that matmul_to_var_expr can
2146 matmul_to_var_code (gfc_code
**c
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2147 void *data ATTRIBUTE_UNUSED
)
2149 if (current_code
!= c
)
2152 inserted_block
= NULL
;
2153 changed_statement
= NULL
;
2160 /* Auxiliary function to build and simplify an array inquiry function.
2161 dim is zero-based. */
2164 get_array_inq_function (gfc_isym_id id
, gfc_expr
*e
, int dim
)
2167 gfc_expr
*dim_arg
, *kind
;
2173 case GFC_ISYM_LBOUND
:
2174 name
= "_gfortran_lbound";
2177 case GFC_ISYM_UBOUND
:
2178 name
= "_gfortran_ubound";
2182 name
= "_gfortran_size";
2189 dim_arg
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
, dim
);
2190 kind
= gfc_get_int_expr (gfc_default_integer_kind
, &e
->where
,
2191 gfc_index_integer_kind
);
2193 ec
= gfc_copy_expr (e
);
2194 fcn
= gfc_build_intrinsic_call (current_ns
, id
, name
, e
->where
, 3,
2196 gfc_simplify_expr (fcn
, 0);
2200 /* Builds a logical expression. */
2203 build_logical_expr (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2208 ts
.type
= BT_LOGICAL
;
2209 ts
.kind
= gfc_default_logical_kind
;
2210 res
= gfc_get_expr ();
2211 res
->where
= e1
->where
;
2212 res
->expr_type
= EXPR_OP
;
2213 res
->value
.op
.op
= op
;
2214 res
->value
.op
.op1
= e1
;
2215 res
->value
.op
.op2
= e2
;
2222 /* Return an operation of one two gfc_expr (one if e2 is NULL). This assumes
2223 compatible typespecs. */
2226 get_operand (gfc_intrinsic_op op
, gfc_expr
*e1
, gfc_expr
*e2
)
2230 res
= gfc_get_expr ();
2232 res
->where
= e1
->where
;
2233 res
->expr_type
= EXPR_OP
;
2234 res
->value
.op
.op
= op
;
2235 res
->value
.op
.op1
= e1
;
2236 res
->value
.op
.op2
= e2
;
2237 gfc_simplify_expr (res
, 0);
2241 /* Generate the IF statement for a runtime check if we want to do inlining or
2242 not - putting in the code for both branches and putting it into the syntax
2243 tree is the caller's responsibility. For fixed array sizes, this should be
2244 removed by DCE. Only called for rank-two matrices A and B. */
2247 inline_limit_check (gfc_expr
*a
, gfc_expr
*b
, enum matrix_case m_case
)
2249 gfc_expr
*inline_limit
;
2250 gfc_code
*if_1
, *if_2
, *else_2
;
2251 gfc_expr
*b2
, *a2
, *a1
, *m1
, *m2
;
2255 gcc_assert (m_case
== A2B2
|| m_case
== A2B2T
|| m_case
== A2TB2
);
2257 /* Calculation is done in real to avoid integer overflow. */
2259 inline_limit
= gfc_get_constant_expr (BT_REAL
, gfc_default_real_kind
,
2261 mpfr_set_si (inline_limit
->value
.real
, flag_inline_matmul_limit
,
2263 mpfr_pow_ui (inline_limit
->value
.real
, inline_limit
->value
.real
, 3,
2266 a1
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2267 a2
= get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2268 b2
= get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2272 ts
.kind
= gfc_default_real_kind
;
2273 gfc_convert_type_warn (a1
, &ts
, 2, 0);
2274 gfc_convert_type_warn (a2
, &ts
, 2, 0);
2275 gfc_convert_type_warn (b2
, &ts
, 2, 0);
2277 m1
= get_operand (INTRINSIC_TIMES
, a1
, a2
);
2278 m2
= get_operand (INTRINSIC_TIMES
, m1
, b2
);
2280 cond
= build_logical_expr (INTRINSIC_LE
, m2
, inline_limit
);
2281 gfc_simplify_expr (cond
, 0);
2283 else_2
= XCNEW (gfc_code
);
2284 else_2
->op
= EXEC_IF
;
2285 else_2
->loc
= a
->where
;
2287 if_2
= XCNEW (gfc_code
);
2290 if_2
->loc
= a
->where
;
2291 if_2
->block
= else_2
;
2293 if_1
= XCNEW (gfc_code
);
2296 if_1
->loc
= a
->where
;
2302 /* Insert code to issue a runtime error if the expressions are not equal. */
2305 runtime_error_ne (gfc_expr
*e1
, gfc_expr
*e2
, const char *msg
)
2308 gfc_code
*if_1
, *if_2
;
2310 gfc_actual_arglist
*a1
, *a2
, *a3
;
2312 gcc_assert (e1
->where
.lb
);
2313 /* Build the call to runtime_error. */
2314 c
= XCNEW (gfc_code
);
2318 /* Get a null-terminated message string. */
2320 a1
= gfc_get_actual_arglist ();
2321 a1
->expr
= gfc_get_character_expr (gfc_default_character_kind
, &e1
->where
,
2322 msg
, strlen(msg
)+1);
2325 /* Pass the value of the first expression. */
2326 a2
= gfc_get_actual_arglist ();
2327 a2
->expr
= gfc_copy_expr (e1
);
2330 /* Pass the value of the second expression. */
2331 a3
= gfc_get_actual_arglist ();
2332 a3
->expr
= gfc_copy_expr (e2
);
2335 gfc_check_fe_runtime_error (c
->ext
.actual
);
2336 gfc_resolve_fe_runtime_error (c
);
2338 if_2
= XCNEW (gfc_code
);
2340 if_2
->loc
= e1
->where
;
2343 if_1
= XCNEW (gfc_code
);
2346 if_1
->loc
= e1
->where
;
2348 cond
= build_logical_expr (INTRINSIC_NE
, e1
, e2
);
2349 gfc_simplify_expr (cond
, 0);
2355 /* Handle matrix reallocation. Caller is responsible to insert into
2358 For the two-dimensional case, build
2360 if (allocated(c)) then
2361 if (size(c,1) /= size(a,1) .or. size(c,2) /= size(b,2)) then
2363 allocate (c(size(a,1), size(b,2)))
2366 allocate (c(size(a,1),size(b,2)))
2369 and for the other cases correspondingly.
2373 matmul_lhs_realloc (gfc_expr
*c
, gfc_expr
*a
, gfc_expr
*b
,
2374 enum matrix_case m_case
)
2377 gfc_expr
*allocated
, *alloc_expr
;
2378 gfc_code
*if_alloc_1
, *if_alloc_2
, *if_size_1
, *if_size_2
;
2379 gfc_code
*else_alloc
;
2380 gfc_code
*deallocate
, *allocate1
, *allocate_else
;
2382 gfc_expr
*cond
, *ne1
, *ne2
;
2384 if (warn_realloc_lhs
)
2385 gfc_warning (OPT_Wrealloc_lhs
,
2386 "Code for reallocating the allocatable array at %L will "
2387 "be added", &c
->where
);
2389 alloc_expr
= gfc_copy_expr (c
);
2391 ar
= gfc_find_array_ref (alloc_expr
);
2392 gcc_assert (ar
&& ar
->type
== AR_FULL
);
2394 /* c comes in as a full ref. Change it into a copy and make it into an
2395 element ref so it has the right form for for ALLOCATE. In the same
2396 switch statement, also generate the size comparison for the secod IF
2399 ar
->type
= AR_ELEMENT
;
2404 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2405 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2406 ne1
= build_logical_expr (INTRINSIC_NE
,
2407 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2408 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2409 ne2
= build_logical_expr (INTRINSIC_NE
,
2410 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2411 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2412 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2416 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2417 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 1);
2419 ne1
= build_logical_expr (INTRINSIC_NE
,
2420 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2421 get_array_inq_function (GFC_ISYM_SIZE
, a
, 1));
2422 ne2
= build_logical_expr (INTRINSIC_NE
,
2423 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2424 get_array_inq_function (GFC_ISYM_SIZE
, b
, 1));
2425 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2430 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 2);
2431 ar
->start
[1] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2433 ne1
= build_logical_expr (INTRINSIC_NE
,
2434 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2435 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2436 ne2
= build_logical_expr (INTRINSIC_NE
,
2437 get_array_inq_function (GFC_ISYM_SIZE
, c
, 2),
2438 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2439 cond
= build_logical_expr (INTRINSIC_OR
, ne1
, ne2
);
2443 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, a
, 1);
2444 cond
= build_logical_expr (INTRINSIC_NE
,
2445 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2446 get_array_inq_function (GFC_ISYM_SIZE
, a
, 2));
2450 ar
->start
[0] = get_array_inq_function (GFC_ISYM_SIZE
, b
, 2);
2451 cond
= build_logical_expr (INTRINSIC_NE
,
2452 get_array_inq_function (GFC_ISYM_SIZE
, c
, 1),
2453 get_array_inq_function (GFC_ISYM_SIZE
, b
, 2));
2461 gfc_simplify_expr (cond
, 0);
2463 /* We need two identical allocate statements in two
2464 branches of the IF statement. */
2466 allocate1
= XCNEW (gfc_code
);
2467 allocate1
->op
= EXEC_ALLOCATE
;
2468 allocate1
->ext
.alloc
.list
= gfc_get_alloc ();
2469 allocate1
->loc
= c
->where
;
2470 allocate1
->ext
.alloc
.list
->expr
= gfc_copy_expr (alloc_expr
);
2472 allocate_else
= XCNEW (gfc_code
);
2473 allocate_else
->op
= EXEC_ALLOCATE
;
2474 allocate_else
->ext
.alloc
.list
= gfc_get_alloc ();
2475 allocate_else
->loc
= c
->where
;
2476 allocate_else
->ext
.alloc
.list
->expr
= alloc_expr
;
2478 allocated
= gfc_build_intrinsic_call (current_ns
, GFC_ISYM_ALLOCATED
,
2479 "_gfortran_allocated", c
->where
,
2480 1, gfc_copy_expr (c
));
2482 deallocate
= XCNEW (gfc_code
);
2483 deallocate
->op
= EXEC_DEALLOCATE
;
2484 deallocate
->ext
.alloc
.list
= gfc_get_alloc ();
2485 deallocate
->ext
.alloc
.list
->expr
= gfc_copy_expr (c
);
2486 deallocate
->next
= allocate1
;
2487 deallocate
->loc
= c
->where
;
2489 if_size_2
= XCNEW (gfc_code
);
2490 if_size_2
->op
= EXEC_IF
;
2491 if_size_2
->expr1
= cond
;
2492 if_size_2
->loc
= c
->where
;
2493 if_size_2
->next
= deallocate
;
2495 if_size_1
= XCNEW (gfc_code
);
2496 if_size_1
->op
= EXEC_IF
;
2497 if_size_1
->block
= if_size_2
;
2498 if_size_1
->loc
= c
->where
;
2500 else_alloc
= XCNEW (gfc_code
);
2501 else_alloc
->op
= EXEC_IF
;
2502 else_alloc
->loc
= c
->where
;
2503 else_alloc
->next
= allocate_else
;
2505 if_alloc_2
= XCNEW (gfc_code
);
2506 if_alloc_2
->op
= EXEC_IF
;
2507 if_alloc_2
->expr1
= allocated
;
2508 if_alloc_2
->loc
= c
->where
;
2509 if_alloc_2
->next
= if_size_1
;
2510 if_alloc_2
->block
= else_alloc
;
2512 if_alloc_1
= XCNEW (gfc_code
);
2513 if_alloc_1
->op
= EXEC_IF
;
2514 if_alloc_1
->block
= if_alloc_2
;
2515 if_alloc_1
->loc
= c
->where
;
2520 /* Callback function for has_function_or_op. */
2523 is_function_or_op (gfc_expr
**e
, int *walk_subtrees ATTRIBUTE_UNUSED
,
2524 void *data ATTRIBUTE_UNUSED
)
2529 return (*e
)->expr_type
== EXPR_FUNCTION
2530 || (*e
)->expr_type
== EXPR_OP
;
2533 /* Returns true if the expression contains a function. */
2536 has_function_or_op (gfc_expr
**e
)
2541 return gfc_expr_walker (e
, is_function_or_op
, NULL
);
2544 /* Freeze (assign to a temporary variable) a single expression. */
2547 freeze_expr (gfc_expr
**ep
)
2550 if (has_function_or_op (ep
))
2552 ne
= create_var (*ep
, "freeze");
2557 /* Go through an expression's references and assign them to temporary
2558 variables if they contain functions. This is usually done prior to
2559 front-end scalarization to avoid multiple invocations of functions. */
2562 freeze_references (gfc_expr
*e
)
2568 for (r
=e
->ref
; r
; r
=r
->next
)
2570 if (r
->type
== REF_SUBSTRING
)
2572 if (r
->u
.ss
.start
!= NULL
)
2573 freeze_expr (&r
->u
.ss
.start
);
2575 if (r
->u
.ss
.end
!= NULL
)
2576 freeze_expr (&r
->u
.ss
.end
);
2578 else if (r
->type
== REF_ARRAY
)
2587 for (i
=0; i
<ar
->dimen
; i
++)
2589 if (ar
->dimen_type
[i
] == DIMEN_RANGE
)
2591 freeze_expr (&ar
->start
[i
]);
2592 freeze_expr (&ar
->end
[i
]);
2593 freeze_expr (&ar
->stride
[i
]);
2595 else if (ar
->dimen_type
[i
] == DIMEN_ELEMENT
)
2597 freeze_expr (&ar
->start
[i
]);
2603 for (i
=0; i
<ar
->dimen
; i
++)
2604 freeze_expr (&ar
->start
[i
]);
2614 /* Convert to gfc_index_integer_kind if needed, just do a copy otherwise. */
2617 convert_to_index_kind (gfc_expr
*e
)
2621 gcc_assert (e
!= NULL
);
2623 res
= gfc_copy_expr (e
);
2625 gcc_assert (e
->ts
.type
== BT_INTEGER
);
2627 if (res
->ts
.kind
!= gfc_index_integer_kind
)
2631 ts
.type
= BT_INTEGER
;
2632 ts
.kind
= gfc_index_integer_kind
;
2634 gfc_convert_type_warn (e
, &ts
, 2, 0);
2640 /* Function to create a DO loop including creation of the
2641 iteration variable. gfc_expr are copied.*/
2644 create_do_loop (gfc_expr
*start
, gfc_expr
*end
, gfc_expr
*step
, locus
*where
,
2645 gfc_namespace
*ns
, char *vname
)
2648 char name
[GFC_MAX_SYMBOL_LEN
+1];
2649 gfc_symtree
*symtree
;
2654 /* Create an expression for the iteration variable. */
2656 sprintf (name
, "__var_%d_do_%s", var_num
++, vname
);
2658 sprintf (name
, "__var_%d_do", var_num
++);
2661 if (gfc_get_sym_tree (name
, ns
, &symtree
, false) != 0)
2664 /* Create the loop variable. */
2666 symbol
= symtree
->n
.sym
;
2667 symbol
->ts
.type
= BT_INTEGER
;
2668 symbol
->ts
.kind
= gfc_index_integer_kind
;
2669 symbol
->attr
.flavor
= FL_VARIABLE
;
2670 symbol
->attr
.referenced
= 1;
2671 symbol
->attr
.dimension
= 0;
2672 symbol
->attr
.fe_temp
= 1;
2673 gfc_commit_symbol (symbol
);
2675 i
= gfc_get_expr ();
2676 i
->expr_type
= EXPR_VARIABLE
;
2680 i
->symtree
= symtree
;
2682 /* ... and the nested DO statements. */
2683 n
= XCNEW (gfc_code
);
2686 n
->ext
.iterator
= gfc_get_iterator ();
2687 n
->ext
.iterator
->var
= i
;
2688 n
->ext
.iterator
->start
= convert_to_index_kind (start
);
2689 n
->ext
.iterator
->end
= convert_to_index_kind (end
);
2691 n
->ext
.iterator
->step
= convert_to_index_kind (step
);
2693 n
->ext
.iterator
->step
= gfc_get_int_expr (gfc_index_integer_kind
,
2696 n2
= XCNEW (gfc_code
);
2704 /* Get the upper bound of the DO loops for matmul along a dimension. This
2708 get_size_m1 (gfc_expr
*e
, int dimen
)
2713 if (gfc_array_dimen_size (e
, dimen
- 1, &size
))
2715 res
= gfc_get_constant_expr (BT_INTEGER
,
2716 gfc_index_integer_kind
, &e
->where
);
2717 mpz_sub_ui (res
->value
.integer
, size
, 1);
2722 res
= get_operand (INTRINSIC_MINUS
,
2723 get_array_inq_function (GFC_ISYM_SIZE
, e
, dimen
),
2724 gfc_get_int_expr (gfc_index_integer_kind
,
2726 gfc_simplify_expr (res
, 0);
2732 /* Function to return a scalarized expression. It is assumed that indices are
2733 zero based to make generation of DO loops easier. A zero as index will
2734 access the first element along a dimension. Single element references will
2735 be skipped. A NULL as an expression will be replaced by a full reference.
2736 This assumes that the index loops have gfc_index_integer_kind, and that all
2737 references have been frozen. */
2740 scalarized_expr (gfc_expr
*e_in
, gfc_expr
**index
, int count_index
)
2749 e
= gfc_copy_expr(e_in
);
2753 ar
= gfc_find_array_ref (e
);
2755 /* We scalarize count_index variables, reducing the rank by count_index. */
2757 e
->rank
= rank
- count_index
;
2759 was_fullref
= ar
->type
== AR_FULL
;
2762 ar
->type
= AR_ELEMENT
;
2764 ar
->type
= AR_SECTION
;
2766 /* Loop over the indices. For each index, create the expression
2767 index * stride + lbound(e, dim). */
2770 for (i
=0; i
< ar
->dimen
; i
++)
2772 if (was_fullref
|| ar
->dimen_type
[i
] == DIMEN_RANGE
)
2774 if (index
[i_index
] != NULL
)
2776 gfc_expr
*lbound
, *nindex
;
2779 loopvar
= gfc_copy_expr (index
[i_index
]);
2785 tmp
= gfc_copy_expr(ar
->stride
[i
]);
2786 if (tmp
->ts
.kind
!= gfc_index_integer_kind
)
2790 ts
.type
= BT_INTEGER
;
2791 ts
.kind
= gfc_index_integer_kind
;
2792 gfc_convert_type (tmp
, &ts
, 2);
2794 nindex
= get_operand (INTRINSIC_TIMES
, loopvar
, tmp
);
2799 /* Calculate the lower bound of the expression. */
2802 lbound
= gfc_copy_expr (ar
->start
[i
]);
2803 if (lbound
->ts
.kind
!= gfc_index_integer_kind
)
2807 ts
.type
= BT_INTEGER
;
2808 ts
.kind
= gfc_index_integer_kind
;
2809 gfc_convert_type (lbound
, &ts
, 2);
2818 lbound_e
= gfc_copy_expr (e_in
);
2820 for (ref
= lbound_e
->ref
; ref
; ref
= ref
->next
)
2821 if (ref
->type
== REF_ARRAY
2822 && (ref
->u
.ar
.type
== AR_FULL
2823 || ref
->u
.ar
.type
== AR_SECTION
))
2828 gfc_free_ref_list (ref
->next
);
2834 /* Look at full individual sections, like a(:). The first index
2835 is the lbound of a full ref. */
2841 for (j
= 0; j
< ar
->dimen
; j
++)
2843 gfc_free_expr (ar
->start
[j
]);
2844 ar
->start
[j
] = NULL
;
2845 gfc_free_expr (ar
->end
[j
]);
2847 gfc_free_expr (ar
->stride
[j
]);
2848 ar
->stride
[j
] = NULL
;
2851 /* We have to get rid of the shape, if there is one. Do
2852 so by freeing it and calling gfc_resolve to rebuild
2853 it, if necessary. */
2855 if (lbound_e
->shape
)
2856 gfc_free_shape (&(lbound_e
->shape
), lbound_e
->rank
);
2858 lbound_e
->rank
= ar
->dimen
;
2859 gfc_resolve_expr (lbound_e
);
2861 lbound
= get_array_inq_function (GFC_ISYM_LBOUND
, lbound_e
,
2863 gfc_free_expr (lbound_e
);
2866 ar
->dimen_type
[i
] = DIMEN_ELEMENT
;
2868 gfc_free_expr (ar
->start
[i
]);
2869 ar
->start
[i
] = get_operand (INTRINSIC_PLUS
, nindex
, lbound
);
2871 gfc_free_expr (ar
->end
[i
]);
2873 gfc_free_expr (ar
->stride
[i
]);
2874 ar
->stride
[i
] = NULL
;
2875 gfc_simplify_expr (ar
->start
[i
], 0);
2877 else if (was_fullref
)
2879 gfc_internal_error ("Scalarization using DIMEN_RANGE unimplemented");
2888 /* Helper function to check for a dimen vector as subscript. */
2891 has_dimen_vector_ref (gfc_expr
*e
)
2896 ar
= gfc_find_array_ref (e
);
2898 if (ar
->type
== AR_FULL
)
2901 for (i
=0; i
<ar
->dimen
; i
++)
2902 if (ar
->dimen_type
[i
] == DIMEN_VECTOR
)
2908 /* If handed an expression of the form
2912 check if A can be handled by matmul and return if there is an uneven number
2913 of CONJG calls. Return a pointer to the array when everything is OK, NULL
2914 otherwise. The caller has to check for the correct rank. */
2917 check_conjg_transpose_variable (gfc_expr
*e
, bool *conjg
, bool *transpose
)
2924 if (e
->expr_type
== EXPR_VARIABLE
)
2926 gcc_assert (e
->rank
== 1 || e
->rank
== 2);
2929 else if (e
->expr_type
== EXPR_FUNCTION
)
2931 if (e
->value
.function
.isym
== NULL
)
2934 if (e
->value
.function
.isym
->id
== GFC_ISYM_CONJG
)
2936 else if (e
->value
.function
.isym
->id
== GFC_ISYM_TRANSPOSE
)
2937 *transpose
= !*transpose
;
2943 e
= e
->value
.function
.actual
->expr
;
2950 /* Inline assignments of the form c = matmul(a,b).
2951 Handle only the cases currently where b and c are rank-two arrays.
2953 This basically translates the code to
2959 do k=0, size(a, 2)-1
2960 do i=0, size(a, 1)-1
2961 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) =
2962 c(i * stride(c,1) + lbound(c,1), j * stride(c,2) + lbound(c,2)) +
2963 a(i * stride(a,1) + lbound(a,1), k * stride(a,2) + lbound(a,2)) *
2964 b(k * stride(b,1) + lbound(b,1), j * stride(b,2) + lbound(b,2))
2973 inline_matmul_assign (gfc_code
**c
, int *walk_subtrees
,
2974 void *data ATTRIBUTE_UNUSED
)
2977 gfc_expr
*expr1
, *expr2
;
2978 gfc_expr
*matrix_a
, *matrix_b
;
2979 gfc_actual_arglist
*a
, *b
;
2980 gfc_code
*do_1
, *do_2
, *do_3
, *assign_zero
, *assign_matmul
;
2982 gfc_expr
*u1
, *u2
, *u3
;
2984 gfc_expr
*ascalar
, *bscalar
, *cscalar
;
2986 gfc_expr
*var_1
, *var_2
, *var_3
;
2989 gfc_intrinsic_op op_times
, op_plus
;
2990 enum matrix_case m_case
;
2992 gfc_code
*if_limit
= NULL
;
2993 gfc_code
**next_code_point
;
2994 bool conjg_a
, conjg_b
, transpose_a
, transpose_b
;
2996 if (co
->op
!= EXEC_ASSIGN
)
3002 /* The BLOCKS generated for the temporary variables and FORALL don't
3004 if (forall_level
> 0)
3007 /* For now don't do anything in OpenMP workshare, it confuses
3008 its translation, which expects only the allowed statements in there.
3009 We should figure out how to parallelize this eventually. */
3010 if (in_omp_workshare
)
3015 if (expr2
->expr_type
!= EXPR_FUNCTION
3016 || expr2
->value
.function
.isym
== NULL
3017 || expr2
->value
.function
.isym
->id
!= GFC_ISYM_MATMUL
)
3021 inserted_block
= NULL
;
3022 changed_statement
= NULL
;
3024 a
= expr2
->value
.function
.actual
;
3025 matrix_a
= check_conjg_transpose_variable (a
->expr
, &conjg_a
, &transpose_a
);
3026 if (matrix_a
== NULL
)
3030 matrix_b
= check_conjg_transpose_variable (b
->expr
, &conjg_b
, &transpose_b
);
3031 if (matrix_b
== NULL
)
3034 if (has_dimen_vector_ref (expr1
) || has_dimen_vector_ref (matrix_a
)
3035 || has_dimen_vector_ref (matrix_b
))
3038 /* We do not handle data dependencies yet. */
3039 if (gfc_check_dependency (expr1
, matrix_a
, true)
3040 || gfc_check_dependency (expr1
, matrix_b
, true))
3044 if (matrix_a
->rank
== 2)
3048 if (matrix_b
->rank
== 2 && !transpose_b
)
3053 if (matrix_b
->rank
== 1)
3055 else /* matrix_b->rank == 2 */
3064 else /* matrix_a->rank == 1 */
3066 if (matrix_b
->rank
== 2)
3076 ns
= insert_block ();
3078 /* Assign the type of the zero expression for initializing the resulting
3079 array, and the expression (+ and * for real, integer and complex;
3080 .and. and .or for logical. */
3082 switch(expr1
->ts
.type
)
3085 zero_e
= gfc_get_int_expr (expr1
->ts
.kind
, &expr1
->where
, 0);
3086 op_times
= INTRINSIC_TIMES
;
3087 op_plus
= INTRINSIC_PLUS
;
3091 op_times
= INTRINSIC_AND
;
3092 op_plus
= INTRINSIC_OR
;
3093 zero_e
= gfc_get_logical_expr (expr1
->ts
.kind
, &expr1
->where
,
3097 zero_e
= gfc_get_constant_expr (BT_REAL
, expr1
->ts
.kind
,
3099 mpfr_set_si (zero_e
->value
.real
, 0, GFC_RND_MODE
);
3100 op_times
= INTRINSIC_TIMES
;
3101 op_plus
= INTRINSIC_PLUS
;
3105 zero_e
= gfc_get_constant_expr (BT_COMPLEX
, expr1
->ts
.kind
,
3107 mpc_set_si_si (zero_e
->value
.complex, 0, 0, GFC_RND_MODE
);
3108 op_times
= INTRINSIC_TIMES
;
3109 op_plus
= INTRINSIC_PLUS
;
3117 current_code
= &ns
->code
;
3119 /* Freeze the references, keeping track of how many temporary variables were
3122 freeze_references (matrix_a
);
3123 freeze_references (matrix_b
);
3124 freeze_references (expr1
);
3127 next_code_point
= current_code
;
3130 next_code_point
= &ns
->code
;
3131 for (i
=0; i
<n_vars
; i
++)
3132 next_code_point
= &(*next_code_point
)->next
;
3135 /* Take care of the inline flag. If the limit check evaluates to a
3136 constant, dead code elimination will eliminate the unneeded branch. */
3138 if (m_case
== A2B2
&& flag_inline_matmul_limit
> 0)
3140 if_limit
= inline_limit_check (matrix_a
, matrix_b
, m_case
);
3142 /* Insert the original statement into the else branch. */
3143 if_limit
->block
->block
->next
= co
;
3146 /* ... and the new ones go into the original one. */
3147 *next_code_point
= if_limit
;
3148 next_code_point
= &if_limit
->block
->next
;
3151 assign_zero
= XCNEW (gfc_code
);
3152 assign_zero
->op
= EXEC_ASSIGN
;
3153 assign_zero
->loc
= co
->loc
;
3154 assign_zero
->expr1
= gfc_copy_expr (expr1
);
3155 assign_zero
->expr2
= zero_e
;
3157 /* Handle the reallocation, if needed. */
3158 if (flag_realloc_lhs
&& gfc_is_reallocatable_lhs (expr1
))
3160 gfc_code
*lhs_alloc
;
3162 /* Only need to check a single dimension for the A2B2 case for
3163 bounds checking, the rest will be allocated. Also check this
3166 if ((gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
) && (m_case
== A2B2
|| m_case
== A2B1
))
3171 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3172 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3173 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3174 "in MATMUL intrinsic: Is %ld, should be %ld");
3175 *next_code_point
= test
;
3176 next_code_point
= &test
->next
;
3180 lhs_alloc
= matmul_lhs_realloc (expr1
, matrix_a
, matrix_b
, m_case
);
3182 *next_code_point
= lhs_alloc
;
3183 next_code_point
= &lhs_alloc
->next
;
3186 else if (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
3189 gfc_expr
*a2
, *b1
, *c1
, *c2
, *a1
, *b2
;
3191 if (m_case
== A2B2
|| m_case
== A2B1
)
3193 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3194 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3195 test
= runtime_error_ne (b1
, a2
, "Dimension of array B incorrect "
3196 "in MATMUL intrinsic: Is %ld, should be %ld");
3197 *next_code_point
= test
;
3198 next_code_point
= &test
->next
;
3200 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3201 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3204 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3205 "MATMUL intrinsic for dimension 1: "
3206 "is %ld, should be %ld");
3207 else if (m_case
== A2B1
)
3208 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3209 "MATMUL intrinsic: "
3210 "is %ld, should be %ld");
3213 *next_code_point
= test
;
3214 next_code_point
= &test
->next
;
3216 else if (m_case
== A1B2
)
3218 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3219 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3220 test
= runtime_error_ne (b1
, a1
, "Dimension of array B incorrect "
3221 "in MATMUL intrinsic: Is %ld, should be %ld");
3222 *next_code_point
= test
;
3223 next_code_point
= &test
->next
;
3225 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3226 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3228 test
= runtime_error_ne (c1
, b2
, "Incorrect extent in return array in "
3229 "MATMUL intrinsic: "
3230 "is %ld, should be %ld");
3232 *next_code_point
= test
;
3233 next_code_point
= &test
->next
;
3238 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3239 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3240 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3241 "MATMUL intrinsic for dimension 2: is %ld, should be %ld");
3243 *next_code_point
= test
;
3244 next_code_point
= &test
->next
;
3247 if (m_case
== A2B2T
)
3249 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3250 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3251 test
= runtime_error_ne (c1
, a1
, "Incorrect extent in return array in "
3252 "MATMUL intrinsic for dimension 1: "
3253 "is %ld, should be %ld");
3255 *next_code_point
= test
;
3256 next_code_point
= &test
->next
;
3258 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3259 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3260 test
= runtime_error_ne (c2
, b1
, "Incorrect extent in return array in "
3261 "MATMUL intrinsic for dimension 2: "
3262 "is %ld, should be %ld");
3263 *next_code_point
= test
;
3264 next_code_point
= &test
->next
;
3266 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3267 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3269 test
= runtime_error_ne (b2
, a2
, "Incorrect extent in argument B in "
3270 "MATMUL intrnisic for dimension 2: "
3271 "is %ld, should be %ld");
3272 *next_code_point
= test
;
3273 next_code_point
= &test
->next
;
3277 if (m_case
== A2TB2
)
3279 c1
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 1);
3280 a2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 2);
3282 test
= runtime_error_ne (c1
, a2
, "Incorrect extent in return array in "
3283 "MATMUL intrinsic for dimension 1: "
3284 "is %ld, should be %ld");
3286 *next_code_point
= test
;
3287 next_code_point
= &test
->next
;
3289 c2
= get_array_inq_function (GFC_ISYM_SIZE
, expr1
, 2);
3290 b2
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 2);
3291 test
= runtime_error_ne (c2
, b2
, "Incorrect extent in return array in "
3292 "MATMUL intrinsic for dimension 2: "
3293 "is %ld, should be %ld");
3294 *next_code_point
= test
;
3295 next_code_point
= &test
->next
;
3297 a1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_a
, 1);
3298 b1
= get_array_inq_function (GFC_ISYM_SIZE
, matrix_b
, 1);
3300 test
= runtime_error_ne (b1
, a1
, "Incorrect extent in argument B in "
3301 "MATMUL intrnisic for dimension 2: "
3302 "is %ld, should be %ld");
3303 *next_code_point
= test
;
3304 next_code_point
= &test
->next
;
3309 *next_code_point
= assign_zero
;
3311 zero
= gfc_get_int_expr (gfc_index_integer_kind
, &co
->loc
, 0);
3313 assign_matmul
= XCNEW (gfc_code
);
3314 assign_matmul
->op
= EXEC_ASSIGN
;
3315 assign_matmul
->loc
= co
->loc
;
3317 /* Get the bounds for the loops, create them and create the scalarized
3323 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3325 u1
= get_size_m1 (matrix_b
, 2);
3326 u2
= get_size_m1 (matrix_a
, 2);
3327 u3
= get_size_m1 (matrix_a
, 1);
3329 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3330 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3331 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3333 do_1
->block
->next
= do_2
;
3334 do_2
->block
->next
= do_3
;
3335 do_3
->block
->next
= assign_matmul
;
3337 var_1
= do_1
->ext
.iterator
->var
;
3338 var_2
= do_2
->ext
.iterator
->var
;
3339 var_3
= do_3
->ext
.iterator
->var
;
3343 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3347 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3351 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3356 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3358 u1
= get_size_m1 (matrix_b
, 1);
3359 u2
= get_size_m1 (matrix_a
, 2);
3360 u3
= get_size_m1 (matrix_a
, 1);
3362 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3363 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3364 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3366 do_1
->block
->next
= do_2
;
3367 do_2
->block
->next
= do_3
;
3368 do_3
->block
->next
= assign_matmul
;
3370 var_1
= do_1
->ext
.iterator
->var
;
3371 var_2
= do_2
->ext
.iterator
->var
;
3372 var_3
= do_3
->ext
.iterator
->var
;
3376 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3380 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3384 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3389 inline_limit_check (matrix_a
, matrix_b
, m_case
);
3391 u1
= get_size_m1 (matrix_a
, 2);
3392 u2
= get_size_m1 (matrix_b
, 2);
3393 u3
= get_size_m1 (matrix_a
, 1);
3395 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3396 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3397 do_3
= create_do_loop (gfc_copy_expr (zero
), u3
, NULL
, &co
->loc
, ns
);
3399 do_1
->block
->next
= do_2
;
3400 do_2
->block
->next
= do_3
;
3401 do_3
->block
->next
= assign_matmul
;
3403 var_1
= do_1
->ext
.iterator
->var
;
3404 var_2
= do_2
->ext
.iterator
->var
;
3405 var_3
= do_3
->ext
.iterator
->var
;
3409 cscalar
= scalarized_expr (co
->expr1
, list
, 2);
3413 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3417 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3422 u1
= get_size_m1 (matrix_b
, 1);
3423 u2
= get_size_m1 (matrix_a
, 1);
3425 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3426 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3428 do_1
->block
->next
= do_2
;
3429 do_2
->block
->next
= assign_matmul
;
3431 var_1
= do_1
->ext
.iterator
->var
;
3432 var_2
= do_2
->ext
.iterator
->var
;
3435 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3439 ascalar
= scalarized_expr (matrix_a
, list
, 2);
3442 bscalar
= scalarized_expr (matrix_b
, list
, 1);
3447 u1
= get_size_m1 (matrix_b
, 2);
3448 u2
= get_size_m1 (matrix_a
, 1);
3450 do_1
= create_do_loop (gfc_copy_expr (zero
), u1
, NULL
, &co
->loc
, ns
);
3451 do_2
= create_do_loop (gfc_copy_expr (zero
), u2
, NULL
, &co
->loc
, ns
);
3453 do_1
->block
->next
= do_2
;
3454 do_2
->block
->next
= assign_matmul
;
3456 var_1
= do_1
->ext
.iterator
->var
;
3457 var_2
= do_2
->ext
.iterator
->var
;
3460 cscalar
= scalarized_expr (co
->expr1
, list
, 1);
3463 ascalar
= scalarized_expr (matrix_a
, list
, 1);
3467 bscalar
= scalarized_expr (matrix_b
, list
, 2);
3476 ascalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3477 matrix_a
->where
, 1, ascalar
);
3480 bscalar
= gfc_build_intrinsic_call (ns
, GFC_ISYM_CONJG
, "conjg",
3481 matrix_b
->where
, 1, bscalar
);
3483 /* First loop comes after the zero assignment. */
3484 assign_zero
->next
= do_1
;
3486 /* Build the assignment expression in the loop. */
3487 assign_matmul
->expr1
= gfc_copy_expr (cscalar
);
3489 mult
= get_operand (op_times
, ascalar
, bscalar
);
3490 assign_matmul
->expr2
= get_operand (op_plus
, cscalar
, mult
);
3492 /* If we don't want to keep the original statement around in
3493 the else branch, we can free it. */
3495 if (if_limit
== NULL
)
3496 gfc_free_statements(co
);
3500 gfc_free_expr (zero
);
3505 #define WALK_SUBEXPR(NODE) \
3508 result = gfc_expr_walker (&(NODE), exprfn, data); \
3513 #define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
3515 /* Walk expression *E, calling EXPRFN on each expression in it. */
3518 gfc_expr_walker (gfc_expr
**e
, walk_expr_fn_t exprfn
, void *data
)
3522 int walk_subtrees
= 1;
3523 gfc_actual_arglist
*a
;
3527 int result
= exprfn (e
, &walk_subtrees
, data
);
3531 switch ((*e
)->expr_type
)
3534 WALK_SUBEXPR ((*e
)->value
.op
.op1
);
3535 WALK_SUBEXPR_TAIL ((*e
)->value
.op
.op2
);
3538 for (a
= (*e
)->value
.function
.actual
; a
; a
= a
->next
)
3539 WALK_SUBEXPR (a
->expr
);
3543 WALK_SUBEXPR ((*e
)->value
.compcall
.base_object
);
3544 for (a
= (*e
)->value
.compcall
.actual
; a
; a
= a
->next
)
3545 WALK_SUBEXPR (a
->expr
);
3548 case EXPR_STRUCTURE
:
3550 for (c
= gfc_constructor_first ((*e
)->value
.constructor
); c
;
3551 c
= gfc_constructor_next (c
))
3553 if (c
->iterator
== NULL
)
3554 WALK_SUBEXPR (c
->expr
);
3558 WALK_SUBEXPR (c
->expr
);
3560 WALK_SUBEXPR (c
->iterator
->var
);
3561 WALK_SUBEXPR (c
->iterator
->start
);
3562 WALK_SUBEXPR (c
->iterator
->end
);
3563 WALK_SUBEXPR (c
->iterator
->step
);
3567 if ((*e
)->expr_type
!= EXPR_ARRAY
)
3570 /* Fall through to the variable case in order to walk the
3574 case EXPR_SUBSTRING
:
3576 for (r
= (*e
)->ref
; r
; r
= r
->next
)
3585 if (ar
->type
== AR_SECTION
|| ar
->type
== AR_ELEMENT
)
3587 for (i
=0; i
< ar
->dimen
; i
++)
3589 WALK_SUBEXPR (ar
->start
[i
]);
3590 WALK_SUBEXPR (ar
->end
[i
]);
3591 WALK_SUBEXPR (ar
->stride
[i
]);
3598 WALK_SUBEXPR (r
->u
.ss
.start
);
3599 WALK_SUBEXPR (r
->u
.ss
.end
);
3615 #define WALK_SUBCODE(NODE) \
3618 result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
3624 /* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
3625 on each expression in it. If any of the hooks returns non-zero, that
3626 value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
3627 no subcodes or subexpressions are traversed. */
3630 gfc_code_walker (gfc_code
**c
, walk_code_fn_t codefn
, walk_expr_fn_t exprfn
,
3633 for (; *c
; c
= &(*c
)->next
)
3635 int walk_subtrees
= 1;
3636 int result
= codefn (c
, &walk_subtrees
, data
);
3643 gfc_actual_arglist
*a
;
3645 gfc_association_list
*alist
;
3646 bool saved_in_omp_workshare
;
3647 bool saved_in_where
;
3649 /* There might be statement insertions before the current code,
3650 which must not affect the expression walker. */
3653 saved_in_omp_workshare
= in_omp_workshare
;
3654 saved_in_where
= in_where
;
3660 WALK_SUBCODE (co
->ext
.block
.ns
->code
);
3661 if (co
->ext
.block
.assoc
)
3663 bool saved_in_assoc_list
= in_assoc_list
;
3665 in_assoc_list
= true;
3666 for (alist
= co
->ext
.block
.assoc
; alist
; alist
= alist
->next
)
3667 WALK_SUBEXPR (alist
->target
);
3669 in_assoc_list
= saved_in_assoc_list
;
3676 WALK_SUBEXPR (co
->ext
.iterator
->var
);
3677 WALK_SUBEXPR (co
->ext
.iterator
->start
);
3678 WALK_SUBEXPR (co
->ext
.iterator
->end
);
3679 WALK_SUBEXPR (co
->ext
.iterator
->step
);
3687 case EXEC_ASSIGN_CALL
:
3688 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3689 WALK_SUBEXPR (a
->expr
);
3693 WALK_SUBEXPR (co
->expr1
);
3694 for (a
= co
->ext
.actual
; a
; a
= a
->next
)
3695 WALK_SUBEXPR (a
->expr
);
3699 WALK_SUBEXPR (co
->expr1
);
3700 for (b
= co
->block
; b
; b
= b
->block
)
3703 for (cp
= b
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3705 WALK_SUBEXPR (cp
->low
);
3706 WALK_SUBEXPR (cp
->high
);
3708 WALK_SUBCODE (b
->next
);
3713 case EXEC_DEALLOCATE
:
3716 for (a
= co
->ext
.alloc
.list
; a
; a
= a
->next
)
3717 WALK_SUBEXPR (a
->expr
);
3722 case EXEC_DO_CONCURRENT
:
3724 gfc_forall_iterator
*fa
;
3725 for (fa
= co
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3727 WALK_SUBEXPR (fa
->var
);
3728 WALK_SUBEXPR (fa
->start
);
3729 WALK_SUBEXPR (fa
->end
);
3730 WALK_SUBEXPR (fa
->stride
);
3732 if (co
->op
== EXEC_FORALL
)
3738 WALK_SUBEXPR (co
->ext
.open
->unit
);
3739 WALK_SUBEXPR (co
->ext
.open
->file
);
3740 WALK_SUBEXPR (co
->ext
.open
->status
);
3741 WALK_SUBEXPR (co
->ext
.open
->access
);
3742 WALK_SUBEXPR (co
->ext
.open
->form
);
3743 WALK_SUBEXPR (co
->ext
.open
->recl
);
3744 WALK_SUBEXPR (co
->ext
.open
->blank
);
3745 WALK_SUBEXPR (co
->ext
.open
->position
);
3746 WALK_SUBEXPR (co
->ext
.open
->action
);
3747 WALK_SUBEXPR (co
->ext
.open
->delim
);
3748 WALK_SUBEXPR (co
->ext
.open
->pad
);
3749 WALK_SUBEXPR (co
->ext
.open
->iostat
);
3750 WALK_SUBEXPR (co
->ext
.open
->iomsg
);
3751 WALK_SUBEXPR (co
->ext
.open
->convert
);
3752 WALK_SUBEXPR (co
->ext
.open
->decimal
);
3753 WALK_SUBEXPR (co
->ext
.open
->encoding
);
3754 WALK_SUBEXPR (co
->ext
.open
->round
);
3755 WALK_SUBEXPR (co
->ext
.open
->sign
);
3756 WALK_SUBEXPR (co
->ext
.open
->asynchronous
);
3757 WALK_SUBEXPR (co
->ext
.open
->id
);
3758 WALK_SUBEXPR (co
->ext
.open
->newunit
);
3759 WALK_SUBEXPR (co
->ext
.open
->share
);
3760 WALK_SUBEXPR (co
->ext
.open
->cc
);
3764 WALK_SUBEXPR (co
->ext
.close
->unit
);
3765 WALK_SUBEXPR (co
->ext
.close
->status
);
3766 WALK_SUBEXPR (co
->ext
.close
->iostat
);
3767 WALK_SUBEXPR (co
->ext
.close
->iomsg
);
3770 case EXEC_BACKSPACE
:
3774 WALK_SUBEXPR (co
->ext
.filepos
->unit
);
3775 WALK_SUBEXPR (co
->ext
.filepos
->iostat
);
3776 WALK_SUBEXPR (co
->ext
.filepos
->iomsg
);
3780 WALK_SUBEXPR (co
->ext
.inquire
->unit
);
3781 WALK_SUBEXPR (co
->ext
.inquire
->file
);
3782 WALK_SUBEXPR (co
->ext
.inquire
->iomsg
);
3783 WALK_SUBEXPR (co
->ext
.inquire
->iostat
);
3784 WALK_SUBEXPR (co
->ext
.inquire
->exist
);
3785 WALK_SUBEXPR (co
->ext
.inquire
->opened
);
3786 WALK_SUBEXPR (co
->ext
.inquire
->number
);
3787 WALK_SUBEXPR (co
->ext
.inquire
->named
);
3788 WALK_SUBEXPR (co
->ext
.inquire
->name
);
3789 WALK_SUBEXPR (co
->ext
.inquire
->access
);
3790 WALK_SUBEXPR (co
->ext
.inquire
->sequential
);
3791 WALK_SUBEXPR (co
->ext
.inquire
->direct
);
3792 WALK_SUBEXPR (co
->ext
.inquire
->form
);
3793 WALK_SUBEXPR (co
->ext
.inquire
->formatted
);
3794 WALK_SUBEXPR (co
->ext
.inquire
->unformatted
);
3795 WALK_SUBEXPR (co
->ext
.inquire
->recl
);
3796 WALK_SUBEXPR (co
->ext
.inquire
->nextrec
);
3797 WALK_SUBEXPR (co
->ext
.inquire
->blank
);
3798 WALK_SUBEXPR (co
->ext
.inquire
->position
);
3799 WALK_SUBEXPR (co
->ext
.inquire
->action
);
3800 WALK_SUBEXPR (co
->ext
.inquire
->read
);
3801 WALK_SUBEXPR (co
->ext
.inquire
->write
);
3802 WALK_SUBEXPR (co
->ext
.inquire
->readwrite
);
3803 WALK_SUBEXPR (co
->ext
.inquire
->delim
);
3804 WALK_SUBEXPR (co
->ext
.inquire
->encoding
);
3805 WALK_SUBEXPR (co
->ext
.inquire
->pad
);
3806 WALK_SUBEXPR (co
->ext
.inquire
->iolength
);
3807 WALK_SUBEXPR (co
->ext
.inquire
->convert
);
3808 WALK_SUBEXPR (co
->ext
.inquire
->strm_pos
);
3809 WALK_SUBEXPR (co
->ext
.inquire
->asynchronous
);
3810 WALK_SUBEXPR (co
->ext
.inquire
->decimal
);
3811 WALK_SUBEXPR (co
->ext
.inquire
->pending
);
3812 WALK_SUBEXPR (co
->ext
.inquire
->id
);
3813 WALK_SUBEXPR (co
->ext
.inquire
->sign
);
3814 WALK_SUBEXPR (co
->ext
.inquire
->size
);
3815 WALK_SUBEXPR (co
->ext
.inquire
->round
);
3819 WALK_SUBEXPR (co
->ext
.wait
->unit
);
3820 WALK_SUBEXPR (co
->ext
.wait
->iostat
);
3821 WALK_SUBEXPR (co
->ext
.wait
->iomsg
);
3822 WALK_SUBEXPR (co
->ext
.wait
->id
);
3827 WALK_SUBEXPR (co
->ext
.dt
->io_unit
);
3828 WALK_SUBEXPR (co
->ext
.dt
->format_expr
);
3829 WALK_SUBEXPR (co
->ext
.dt
->rec
);
3830 WALK_SUBEXPR (co
->ext
.dt
->advance
);
3831 WALK_SUBEXPR (co
->ext
.dt
->iostat
);
3832 WALK_SUBEXPR (co
->ext
.dt
->size
);
3833 WALK_SUBEXPR (co
->ext
.dt
->iomsg
);
3834 WALK_SUBEXPR (co
->ext
.dt
->id
);
3835 WALK_SUBEXPR (co
->ext
.dt
->pos
);
3836 WALK_SUBEXPR (co
->ext
.dt
->asynchronous
);
3837 WALK_SUBEXPR (co
->ext
.dt
->blank
);
3838 WALK_SUBEXPR (co
->ext
.dt
->decimal
);
3839 WALK_SUBEXPR (co
->ext
.dt
->delim
);
3840 WALK_SUBEXPR (co
->ext
.dt
->pad
);
3841 WALK_SUBEXPR (co
->ext
.dt
->round
);
3842 WALK_SUBEXPR (co
->ext
.dt
->sign
);
3843 WALK_SUBEXPR (co
->ext
.dt
->extra_comma
);
3846 case EXEC_OMP_PARALLEL
:
3847 case EXEC_OMP_PARALLEL_DO
:
3848 case EXEC_OMP_PARALLEL_DO_SIMD
:
3849 case EXEC_OMP_PARALLEL_SECTIONS
:
3851 in_omp_workshare
= false;
3853 /* This goto serves as a shortcut to avoid code
3854 duplication or a larger if or switch statement. */
3855 goto check_omp_clauses
;
3857 case EXEC_OMP_WORKSHARE
:
3858 case EXEC_OMP_PARALLEL_WORKSHARE
:
3860 in_omp_workshare
= true;
3864 case EXEC_OMP_CRITICAL
:
3865 case EXEC_OMP_DISTRIBUTE
:
3866 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO
:
3867 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
3868 case EXEC_OMP_DISTRIBUTE_SIMD
:
3870 case EXEC_OMP_DO_SIMD
:
3871 case EXEC_OMP_ORDERED
:
3872 case EXEC_OMP_SECTIONS
:
3873 case EXEC_OMP_SINGLE
:
3874 case EXEC_OMP_END_SINGLE
:
3876 case EXEC_OMP_TASKLOOP
:
3877 case EXEC_OMP_TASKLOOP_SIMD
:
3878 case EXEC_OMP_TARGET
:
3879 case EXEC_OMP_TARGET_DATA
:
3880 case EXEC_OMP_TARGET_ENTER_DATA
:
3881 case EXEC_OMP_TARGET_EXIT_DATA
:
3882 case EXEC_OMP_TARGET_PARALLEL
:
3883 case EXEC_OMP_TARGET_PARALLEL_DO
:
3884 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
3885 case EXEC_OMP_TARGET_SIMD
:
3886 case EXEC_OMP_TARGET_TEAMS
:
3887 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
3888 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3889 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3890 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
3891 case EXEC_OMP_TARGET_UPDATE
:
3893 case EXEC_OMP_TEAMS
:
3894 case EXEC_OMP_TEAMS_DISTRIBUTE
:
3895 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
3896 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
3897 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD
:
3899 /* Come to this label only from the
3900 EXEC_OMP_PARALLEL_* cases above. */
3904 if (co
->ext
.omp_clauses
)
3906 gfc_omp_namelist
*n
;
3907 static int list_types
[]
3908 = { OMP_LIST_ALIGNED
, OMP_LIST_LINEAR
, OMP_LIST_DEPEND
,
3909 OMP_LIST_MAP
, OMP_LIST_TO
, OMP_LIST_FROM
};
3911 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_expr
);
3912 WALK_SUBEXPR (co
->ext
.omp_clauses
->final_expr
);
3913 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_threads
);
3914 WALK_SUBEXPR (co
->ext
.omp_clauses
->chunk_size
);
3915 WALK_SUBEXPR (co
->ext
.omp_clauses
->safelen_expr
);
3916 WALK_SUBEXPR (co
->ext
.omp_clauses
->simdlen_expr
);
3917 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_teams
);
3918 WALK_SUBEXPR (co
->ext
.omp_clauses
->device
);
3919 WALK_SUBEXPR (co
->ext
.omp_clauses
->thread_limit
);
3920 WALK_SUBEXPR (co
->ext
.omp_clauses
->dist_chunk_size
);
3921 WALK_SUBEXPR (co
->ext
.omp_clauses
->grainsize
);
3922 WALK_SUBEXPR (co
->ext
.omp_clauses
->hint
);
3923 WALK_SUBEXPR (co
->ext
.omp_clauses
->num_tasks
);
3924 WALK_SUBEXPR (co
->ext
.omp_clauses
->priority
);
3925 for (idx
= 0; idx
< OMP_IF_LAST
; idx
++)
3926 WALK_SUBEXPR (co
->ext
.omp_clauses
->if_exprs
[idx
]);
3928 idx
< sizeof (list_types
) / sizeof (list_types
[0]);
3930 for (n
= co
->ext
.omp_clauses
->lists
[list_types
[idx
]];
3932 WALK_SUBEXPR (n
->expr
);
3939 WALK_SUBEXPR (co
->expr1
);
3940 WALK_SUBEXPR (co
->expr2
);
3941 WALK_SUBEXPR (co
->expr3
);
3942 WALK_SUBEXPR (co
->expr4
);
3943 for (b
= co
->block
; b
; b
= b
->block
)
3945 WALK_SUBEXPR (b
->expr1
);
3946 WALK_SUBEXPR (b
->expr2
);
3947 WALK_SUBCODE (b
->next
);
3950 if (co
->op
== EXEC_FORALL
)
3953 if (co
->op
== EXEC_DO
)
3956 in_omp_workshare
= saved_in_omp_workshare
;
3957 in_where
= saved_in_where
;