1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
36 #include "trans-stmt.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 #include "trans-const.h"
42 int has_alternate_specifier
;
44 typedef struct iter_info
50 struct iter_info
*next
;
54 typedef struct temporary_list
57 struct temporary_list
*next
;
61 typedef struct forall_info
69 struct forall_info
*outer
;
70 struct forall_info
*next_nest
;
74 static void gfc_trans_where_2 (gfc_code
*, tree
, tree
, forall_info
*,
75 stmtblock_t
*, temporary_list
**temp
);
77 /* Translate a F95 label number to a LABEL_EXPR. */
80 gfc_trans_label_here (gfc_code
* code
)
82 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
85 /* Translate a label assignment statement. */
87 gfc_trans_label_assign (gfc_code
* code
)
97 /* Start a new block. */
98 gfc_init_se (&se
, NULL
);
99 gfc_start_block (&se
.pre
);
100 gfc_conv_expr (&se
, code
->expr
);
101 len
= GFC_DECL_STRING_LEN (se
.expr
);
102 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
104 label_tree
= gfc_get_label_decl (code
->label
);
106 if (code
->label
->defined
== ST_LABEL_TARGET
)
108 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
109 len_tree
= integer_minus_one_node
;
113 label_str
= code
->label
->format
->value
.character
.string
;
114 label_len
= code
->label
->format
->value
.character
.length
;
115 len_tree
= build_int_cst (NULL_TREE
, label_len
);
116 label_tree
= gfc_build_string_const (label_len
+ 1, label_str
);
117 label_tree
= gfc_build_addr_expr (pchar_type_node
, label_tree
);
120 gfc_add_modify_expr (&se
.pre
, len
, len_tree
);
121 gfc_add_modify_expr (&se
.pre
, addr
, label_tree
);
123 return gfc_finish_block (&se
.pre
);
126 /* Translate a GOTO statement. */
129 gfc_trans_goto (gfc_code
* code
)
139 if (code
->label
!= NULL
)
140 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
143 gfc_init_se (&se
, NULL
);
144 gfc_start_block (&se
.pre
);
145 gfc_conv_expr (&se
, code
->expr
);
147 gfc_build_cstring_const ("Assigned label is not a target label");
148 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
149 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, integer_minus_one_node
);
150 gfc_trans_runtime_check (tmp
, assign_error
, &se
.pre
);
152 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
153 target
= build1 (GOTO_EXPR
, void_type_node
, assigned_goto
);
158 gfc_add_expr_to_block (&se
.pre
, target
);
159 return gfc_finish_block (&se
.pre
);
162 /* Check the label list. */
163 range_error
= gfc_build_cstring_const ("Assigned label is not in the list");
167 tmp
= gfc_get_label_decl (code
->label
);
168 tmp
= gfc_build_addr_expr (pvoid_type_node
, tmp
);
169 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
170 tmp
= build3_v (COND_EXPR
, tmp
, target
, build_empty_stmt ());
171 gfc_add_expr_to_block (&se
.pre
, tmp
);
174 while (code
!= NULL
);
175 gfc_trans_runtime_check (boolean_true_node
, range_error
, &se
.pre
);
176 return gfc_finish_block (&se
.pre
);
180 /* Translate an ENTRY statement. Just adds a label for this entry point. */
182 gfc_trans_entry (gfc_code
* code
)
184 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
188 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
191 gfc_trans_call (gfc_code
* code
)
195 /* A CALL starts a new block because the actual arguments may have to
196 be evaluated first. */
197 gfc_init_se (&se
, NULL
);
198 gfc_start_block (&se
.pre
);
200 gcc_assert (code
->resolved_sym
);
201 has_alternate_specifier
= 0;
203 /* Translate the call. */
204 gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
206 /* A subroutine without side-effect, by definition, does nothing! */
207 TREE_SIDE_EFFECTS (se
.expr
) = 1;
209 /* Chain the pieces together and return the block. */
210 if (has_alternate_specifier
)
212 gfc_code
*select_code
;
214 select_code
= code
->next
;
215 gcc_assert(select_code
->op
== EXEC_SELECT
);
216 sym
= select_code
->expr
->symtree
->n
.sym
;
217 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
218 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
221 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
223 gfc_add_block_to_block (&se
.pre
, &se
.post
);
224 return gfc_finish_block (&se
.pre
);
228 /* Translate the RETURN statement. */
231 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
239 /* if code->expr is not NULL, this return statement must appear
240 in a subroutine and current_fake_result_decl has already
243 result
= gfc_get_fake_result_decl (NULL
);
246 gfc_warning ("An alternate return at %L without a * dummy argument",
248 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
251 /* Start a new block for this statement. */
252 gfc_init_se (&se
, NULL
);
253 gfc_start_block (&se
.pre
);
255 gfc_conv_expr (&se
, code
->expr
);
257 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
258 gfc_add_expr_to_block (&se
.pre
, tmp
);
260 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
261 gfc_add_expr_to_block (&se
.pre
, tmp
);
262 gfc_add_block_to_block (&se
.pre
, &se
.post
);
263 return gfc_finish_block (&se
.pre
);
266 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
270 /* Translate the PAUSE statement. We have to translate this statement
271 to a runtime library call. */
274 gfc_trans_pause (gfc_code
* code
)
276 tree gfc_int4_type_node
= gfc_get_int_type (4);
282 /* Start a new block for this statement. */
283 gfc_init_se (&se
, NULL
);
284 gfc_start_block (&se
.pre
);
287 if (code
->expr
== NULL
)
289 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
290 args
= gfc_chainon_list (NULL_TREE
, tmp
);
291 fndecl
= gfor_fndecl_pause_numeric
;
295 gfc_conv_expr_reference (&se
, code
->expr
);
296 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
297 args
= gfc_chainon_list (args
, se
.string_length
);
298 fndecl
= gfor_fndecl_pause_string
;
301 tmp
= gfc_build_function_call (fndecl
, args
);
302 gfc_add_expr_to_block (&se
.pre
, tmp
);
304 gfc_add_block_to_block (&se
.pre
, &se
.post
);
306 return gfc_finish_block (&se
.pre
);
310 /* Translate the STOP statement. We have to translate this statement
311 to a runtime library call. */
314 gfc_trans_stop (gfc_code
* code
)
316 tree gfc_int4_type_node
= gfc_get_int_type (4);
322 /* Start a new block for this statement. */
323 gfc_init_se (&se
, NULL
);
324 gfc_start_block (&se
.pre
);
327 if (code
->expr
== NULL
)
329 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
330 args
= gfc_chainon_list (NULL_TREE
, tmp
);
331 fndecl
= gfor_fndecl_stop_numeric
;
335 gfc_conv_expr_reference (&se
, code
->expr
);
336 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
337 args
= gfc_chainon_list (args
, se
.string_length
);
338 fndecl
= gfor_fndecl_stop_string
;
341 tmp
= gfc_build_function_call (fndecl
, args
);
342 gfc_add_expr_to_block (&se
.pre
, tmp
);
344 gfc_add_block_to_block (&se
.pre
, &se
.post
);
346 return gfc_finish_block (&se
.pre
);
350 /* Generate GENERIC for the IF construct. This function also deals with
351 the simple IF statement, because the front end translates the IF
352 statement into an IF construct.
384 where COND_S is the simplified version of the predicate. PRE_COND_S
385 are the pre side-effects produced by the translation of the
387 We need to build the chain recursively otherwise we run into
388 problems with folding incomplete statements. */
391 gfc_trans_if_1 (gfc_code
* code
)
396 /* Check for an unconditional ELSE clause. */
398 return gfc_trans_code (code
->next
);
400 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
401 gfc_init_se (&if_se
, NULL
);
402 gfc_start_block (&if_se
.pre
);
404 /* Calculate the IF condition expression. */
405 gfc_conv_expr_val (&if_se
, code
->expr
);
407 /* Translate the THEN clause. */
408 stmt
= gfc_trans_code (code
->next
);
410 /* Translate the ELSE clause. */
412 elsestmt
= gfc_trans_if_1 (code
->block
);
414 elsestmt
= build_empty_stmt ();
416 /* Build the condition expression and add it to the condition block. */
417 stmt
= build3_v (COND_EXPR
, if_se
.expr
, stmt
, elsestmt
);
419 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
421 /* Finish off this statement. */
422 return gfc_finish_block (&if_se
.pre
);
426 gfc_trans_if (gfc_code
* code
)
428 /* Ignore the top EXEC_IF, it only announces an IF construct. The
429 actual code we must translate is in code->block. */
431 return gfc_trans_if_1 (code
->block
);
435 /* Translage an arithmetic IF expression.
437 IF (cond) label1, label2, label3 translates to
451 gfc_trans_arithmetic_if (gfc_code
* code
)
459 /* Start a new block. */
460 gfc_init_se (&se
, NULL
);
461 gfc_start_block (&se
.pre
);
463 /* Pre-evaluate COND. */
464 gfc_conv_expr_val (&se
, code
->expr
);
466 /* Build something to compare with. */
467 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
469 /* If (cond < 0) take branch1 else take branch2.
470 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
471 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
472 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
474 tmp
= build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
475 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
477 /* if (cond <= 0) take branch1 else take branch2. */
478 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
479 tmp
= build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
480 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
482 /* Append the COND_EXPR to the evaluation of COND, and return. */
483 gfc_add_expr_to_block (&se
.pre
, branch1
);
484 return gfc_finish_block (&se
.pre
);
488 /* Translate the DO construct. This obviously is one of the most
489 important ones to get right with any compiler, but especially
492 Currently we calculate the loop count before entering the loop, but
493 it may be possible to optimize if step is a constant. The main
494 advantage is that the loop test is a single GENERIC node
496 We translate a do loop from:
498 DO dovar = from, to, step
508 temp1=to_expr-from_expr;
510 range_temp=step_tmp/range_temp;
511 for ( ; range_temp > 0 ; range_temp = range_temp - 1)
516 dovar=dovar_temp + step_temp;
520 Some optimization is done for empty do loops. We can't just let
521 dovar=to because it's possible for from+range*loopcount!=to. Anyone
522 who writes empty DO deserves sub-optimal (but correct) code anyway.
524 TODO: Large loop counts
525 Does not work loop counts which do not fit into a signed integer kind,
526 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
527 We must support the full range. */
530 gfc_trans_do (gfc_code
* code
)
546 gfc_start_block (&block
);
548 /* Create GIMPLE versions of all expressions in the iterator. */
550 gfc_init_se (&se
, NULL
);
551 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
552 gfc_add_block_to_block (&block
, &se
.pre
);
554 type
= TREE_TYPE (dovar
);
556 gfc_init_se (&se
, NULL
);
557 gfc_conv_expr_type (&se
, code
->ext
.iterator
->start
, type
);
558 gfc_add_block_to_block (&block
, &se
.pre
);
561 gfc_init_se (&se
, NULL
);
562 gfc_conv_expr_type (&se
, code
->ext
.iterator
->end
, type
);
563 gfc_add_block_to_block (&block
, &se
.pre
);
566 gfc_init_se (&se
, NULL
);
567 gfc_conv_expr_type (&se
, code
->ext
.iterator
->step
, type
);
569 /* We don't want this changing part way through. */
570 gfc_make_safe_expr (&se
);
571 gfc_add_block_to_block (&block
, &se
.pre
);
574 /* Initialize loop count. This code is executed before we enter the
575 loop body. We generate: count = (to + step - from) / step. */
577 tmp
= fold (build2 (MINUS_EXPR
, type
, step
, from
));
578 tmp
= fold (build2 (PLUS_EXPR
, type
, to
, tmp
));
579 tmp
= fold (build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
));
581 count
= gfc_create_var (type
, "count");
582 gfc_add_modify_expr (&block
, count
, tmp
);
584 /* Initialize the DO variable: dovar = from. */
585 gfc_add_modify_expr (&block
, dovar
, from
);
588 gfc_start_block (&body
);
590 /* Cycle and exit statements are implemented with gotos. */
591 cycle_label
= gfc_build_label_decl (NULL_TREE
);
592 exit_label
= gfc_build_label_decl (NULL_TREE
);
594 /* Start with the loop condition. Loop until count <= 0. */
595 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
596 tmp
= build1_v (GOTO_EXPR
, exit_label
);
597 TREE_USED (exit_label
) = 1;
598 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
599 gfc_add_expr_to_block (&body
, tmp
);
601 /* Put these labels where they can be found later. We put the
602 labels in a TREE_LIST node (because TREE_CHAIN is already
603 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
604 label in TREE_VALUE (backend_decl). */
606 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
608 /* Main loop body. */
609 tmp
= gfc_trans_code (code
->block
->next
);
610 gfc_add_expr_to_block (&body
, tmp
);
612 /* Label for cycle statements (if needed). */
613 if (TREE_USED (cycle_label
))
615 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
616 gfc_add_expr_to_block (&body
, tmp
);
619 /* Increment the loop variable. */
620 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
621 gfc_add_modify_expr (&body
, dovar
, tmp
);
623 /* Decrement the loop count. */
624 tmp
= build2 (MINUS_EXPR
, type
, count
, gfc_index_one_node
);
625 gfc_add_modify_expr (&body
, count
, tmp
);
627 /* End of loop body. */
628 tmp
= gfc_finish_block (&body
);
630 /* The for loop itself. */
631 tmp
= build1_v (LOOP_EXPR
, tmp
);
632 gfc_add_expr_to_block (&block
, tmp
);
634 /* Add the exit label. */
635 tmp
= build1_v (LABEL_EXPR
, exit_label
);
636 gfc_add_expr_to_block (&block
, tmp
);
638 return gfc_finish_block (&block
);
642 /* Translate the DO WHILE construct.
655 if (! cond) goto exit_label;
661 Because the evaluation of the exit condition `cond' may have side
662 effects, we can't do much for empty loop bodies. The backend optimizers
663 should be smart enough to eliminate any dead loops. */
666 gfc_trans_do_while (gfc_code
* code
)
674 /* Everything we build here is part of the loop body. */
675 gfc_start_block (&block
);
677 /* Cycle and exit statements are implemented with gotos. */
678 cycle_label
= gfc_build_label_decl (NULL_TREE
);
679 exit_label
= gfc_build_label_decl (NULL_TREE
);
681 /* Put the labels where they can be found later. See gfc_trans_do(). */
682 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
684 /* Create a GIMPLE version of the exit condition. */
685 gfc_init_se (&cond
, NULL
);
686 gfc_conv_expr_val (&cond
, code
->expr
);
687 gfc_add_block_to_block (&block
, &cond
.pre
);
688 cond
.expr
= fold (build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
));
690 /* Build "IF (! cond) GOTO exit_label". */
691 tmp
= build1_v (GOTO_EXPR
, exit_label
);
692 TREE_USED (exit_label
) = 1;
693 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
694 gfc_add_expr_to_block (&block
, tmp
);
696 /* The main body of the loop. */
697 tmp
= gfc_trans_code (code
->block
->next
);
698 gfc_add_expr_to_block (&block
, tmp
);
700 /* Label for cycle statements (if needed). */
701 if (TREE_USED (cycle_label
))
703 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
704 gfc_add_expr_to_block (&block
, tmp
);
707 /* End of loop body. */
708 tmp
= gfc_finish_block (&block
);
710 gfc_init_block (&block
);
711 /* Build the loop. */
712 tmp
= build1_v (LOOP_EXPR
, tmp
);
713 gfc_add_expr_to_block (&block
, tmp
);
715 /* Add the exit label. */
716 tmp
= build1_v (LABEL_EXPR
, exit_label
);
717 gfc_add_expr_to_block (&block
, tmp
);
719 return gfc_finish_block (&block
);
723 /* Translate the SELECT CASE construct for INTEGER case expressions,
724 without killing all potential optimizations. The problem is that
725 Fortran allows unbounded cases, but the back-end does not, so we
726 need to intercept those before we enter the equivalent SWITCH_EXPR
729 For example, we translate this,
732 CASE (:100,101,105:115)
742 to the GENERIC equivalent,
746 case (minimum value for typeof(expr) ... 100:
752 case 200 ... (maximum value for typeof(expr):
769 gfc_trans_integer_select (gfc_code
* code
)
779 gfc_start_block (&block
);
781 /* Calculate the switch expression. */
782 gfc_init_se (&se
, NULL
);
783 gfc_conv_expr_val (&se
, code
->expr
);
784 gfc_add_block_to_block (&block
, &se
.pre
);
786 end_label
= gfc_build_label_decl (NULL_TREE
);
788 gfc_init_block (&body
);
790 for (c
= code
->block
; c
; c
= c
->block
)
792 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
797 /* Assume it's the default case. */
798 low
= high
= NULL_TREE
;
802 low
= gfc_conv_constant_to_tree (cp
->low
);
804 /* If there's only a lower bound, set the high bound to the
805 maximum value of the case expression. */
807 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
812 /* Three cases are possible here:
814 1) There is no lower bound, e.g. CASE (:N).
815 2) There is a lower bound .NE. high bound, that is
816 a case range, e.g. CASE (N:M) where M>N (we make
817 sure that M>N during type resolution).
818 3) There is a lower bound, and it has the same value
819 as the high bound, e.g. CASE (N:N). This is our
820 internal representation of CASE(N).
822 In the first and second case, we need to set a value for
823 high. In the thirth case, we don't because the GCC middle
824 end represents a single case value by just letting high be
825 a NULL_TREE. We can't do that because we need to be able
826 to represent unbounded cases. */
830 && mpz_cmp (cp
->low
->value
.integer
,
831 cp
->high
->value
.integer
) != 0))
832 high
= gfc_conv_constant_to_tree (cp
->high
);
834 /* Unbounded case. */
836 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
840 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
841 DECL_CONTEXT (label
) = current_function_decl
;
843 /* Add this case label.
844 Add parameter 'label', make it match GCC backend. */
845 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
846 gfc_add_expr_to_block (&body
, tmp
);
849 /* Add the statements for this case. */
850 tmp
= gfc_trans_code (c
->next
);
851 gfc_add_expr_to_block (&body
, tmp
);
853 /* Break to the end of the construct. */
854 tmp
= build1_v (GOTO_EXPR
, end_label
);
855 gfc_add_expr_to_block (&body
, tmp
);
858 tmp
= gfc_finish_block (&body
);
859 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
860 gfc_add_expr_to_block (&block
, tmp
);
862 tmp
= build1_v (LABEL_EXPR
, end_label
);
863 gfc_add_expr_to_block (&block
, tmp
);
865 return gfc_finish_block (&block
);
869 /* Translate the SELECT CASE construct for LOGICAL case expressions.
871 There are only two cases possible here, even though the standard
872 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
873 .FALSE., and DEFAULT.
875 We never generate more than two blocks here. Instead, we always
876 try to eliminate the DEFAULT case. This way, we can translate this
877 kind of SELECT construct to a simple
881 expression in GENERIC. */
884 gfc_trans_logical_select (gfc_code
* code
)
892 /* Assume we don't have any cases at all. */
895 /* Now see which ones we actually do have. We can have at most two
896 cases in a single case list: one for .TRUE. and one for .FALSE.
897 The default case is always separate. If the cases for .TRUE. and
898 .FALSE. are in the same case list, the block for that case list
899 always executed, and we don't generate code a COND_EXPR. */
900 for (c
= code
->block
; c
; c
= c
->block
)
902 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
906 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
908 else /* if (cp->value.logical != 0), thus .TRUE. */
916 /* Start a new block. */
917 gfc_start_block (&block
);
919 /* Calculate the switch expression. We always need to do this
920 because it may have side effects. */
921 gfc_init_se (&se
, NULL
);
922 gfc_conv_expr_val (&se
, code
->expr
);
923 gfc_add_block_to_block (&block
, &se
.pre
);
925 if (t
== f
&& t
!= NULL
)
927 /* Cases for .TRUE. and .FALSE. are in the same block. Just
928 translate the code for these cases, append it to the current
930 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
934 tree true_tree
, false_tree
;
936 true_tree
= build_empty_stmt ();
937 false_tree
= build_empty_stmt ();
939 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
940 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
941 make the missing case the default case. */
942 if (t
!= NULL
&& f
!= NULL
)
952 /* Translate the code for each of these blocks, and append it to
953 the current block. */
955 true_tree
= gfc_trans_code (t
->next
);
958 false_tree
= gfc_trans_code (f
->next
);
960 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
961 true_tree
, false_tree
));
964 return gfc_finish_block (&block
);
968 /* Translate the SELECT CASE construct for CHARACTER case expressions.
969 Instead of generating compares and jumps, it is far simpler to
970 generate a data structure describing the cases in order and call a
971 library subroutine that locates the right case.
972 This is particularly true because this is the only case where we
973 might have to dispose of a temporary.
974 The library subroutine returns a pointer to jump to or NULL if no
975 branches are to be taken. */
978 gfc_trans_character_select (gfc_code
*code
)
980 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
981 stmtblock_t block
, body
;
987 static tree select_struct
;
988 static tree ss_string1
, ss_string1_len
;
989 static tree ss_string2
, ss_string2_len
;
990 static tree ss_target
;
992 if (select_struct
== NULL
)
994 tree gfc_int4_type_node
= gfc_get_int_type (4);
996 select_struct
= make_node (RECORD_TYPE
);
997 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1000 #define ADD_FIELD(NAME, TYPE) \
1001 ss_##NAME = gfc_add_field_to_struct \
1002 (&(TYPE_FIELDS (select_struct)), select_struct, \
1003 get_identifier (stringize(NAME)), TYPE)
1005 ADD_FIELD (string1
, pchar_type_node
);
1006 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1008 ADD_FIELD (string2
, pchar_type_node
);
1009 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1011 ADD_FIELD (target
, pvoid_type_node
);
1014 gfc_finish_type (select_struct
);
1017 cp
= code
->block
->ext
.case_list
;
1018 while (cp
->left
!= NULL
)
1022 for (d
= cp
; d
; d
= d
->right
)
1026 labels
= gfc_getmem (n
* sizeof (tree
));
1030 for(i
= 0; i
< n
; i
++)
1032 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1033 TREE_USED (labels
[i
]) = 1;
1034 /* TODO: The gimplifier should do this for us, but it has
1035 inadequacies when dealing with static initializers. */
1036 FORCED_LABEL (labels
[i
]) = 1;
1039 end_label
= gfc_build_label_decl (NULL_TREE
);
1041 /* Generate the body */
1042 gfc_start_block (&block
);
1043 gfc_init_block (&body
);
1045 for (c
= code
->block
; c
; c
= c
->block
)
1047 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1049 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1050 gfc_add_expr_to_block (&body
, tmp
);
1053 tmp
= gfc_trans_code (c
->next
);
1054 gfc_add_expr_to_block (&body
, tmp
);
1056 tmp
= build1_v (GOTO_EXPR
, end_label
);
1057 gfc_add_expr_to_block (&body
, tmp
);
1060 /* Generate the structure describing the branches */
1064 for(d
= cp
; d
; d
= d
->right
, i
++)
1068 gfc_init_se (&se
, NULL
);
1072 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1073 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1077 gfc_conv_expr_reference (&se
, d
->low
);
1079 node
= tree_cons (ss_string1
, se
.expr
, node
);
1080 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1083 if (d
->high
== NULL
)
1085 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1086 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1090 gfc_init_se (&se
, NULL
);
1091 gfc_conv_expr_reference (&se
, d
->high
);
1093 node
= tree_cons (ss_string2
, se
.expr
, node
);
1094 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1097 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1098 node
= tree_cons (ss_target
, tmp
, node
);
1100 tmp
= build1 (CONSTRUCTOR
, select_struct
, nreverse (node
));
1101 init
= tree_cons (NULL_TREE
, tmp
, init
);
1104 type
= build_array_type (select_struct
, build_index_type
1105 (build_int_cst (NULL_TREE
, n
- 1)));
1107 init
= build1 (CONSTRUCTOR
, type
, nreverse(init
));
1108 TREE_CONSTANT (init
) = 1;
1109 TREE_INVARIANT (init
) = 1;
1110 TREE_STATIC (init
) = 1;
1111 /* Create a static variable to hold the jump table. */
1112 tmp
= gfc_create_var (type
, "jumptable");
1113 TREE_CONSTANT (tmp
) = 1;
1114 TREE_INVARIANT (tmp
) = 1;
1115 TREE_STATIC (tmp
) = 1;
1116 DECL_INITIAL (tmp
) = init
;
1119 /* Build an argument list for the library call */
1120 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1121 args
= gfc_chainon_list (NULL_TREE
, init
);
1123 tmp
= build_int_cst (NULL_TREE
, n
);
1124 args
= gfc_chainon_list (args
, tmp
);
1126 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1127 args
= gfc_chainon_list (args
, tmp
);
1129 gfc_init_se (&se
, NULL
);
1130 gfc_conv_expr_reference (&se
, code
->expr
);
1132 args
= gfc_chainon_list (args
, se
.expr
);
1133 args
= gfc_chainon_list (args
, se
.string_length
);
1135 gfc_add_block_to_block (&block
, &se
.pre
);
1137 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1138 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1139 gfc_add_expr_to_block (&block
, tmp
);
1141 tmp
= gfc_finish_block (&body
);
1142 gfc_add_expr_to_block (&block
, tmp
);
1143 tmp
= build1_v (LABEL_EXPR
, end_label
);
1144 gfc_add_expr_to_block (&block
, tmp
);
1149 return gfc_finish_block (&block
);
1153 /* Translate the three variants of the SELECT CASE construct.
1155 SELECT CASEs with INTEGER case expressions can be translated to an
1156 equivalent GENERIC switch statement, and for LOGICAL case
1157 expressions we build one or two if-else compares.
1159 SELECT CASEs with CHARACTER case expressions are a whole different
1160 story, because they don't exist in GENERIC. So we sort them and
1161 do a binary search at runtime.
1163 Fortran has no BREAK statement, and it does not allow jumps from
1164 one case block to another. That makes things a lot easier for
1168 gfc_trans_select (gfc_code
* code
)
1170 gcc_assert (code
&& code
->expr
);
1172 /* Empty SELECT constructs are legal. */
1173 if (code
->block
== NULL
)
1174 return build_empty_stmt ();
1176 /* Select the correct translation function. */
1177 switch (code
->expr
->ts
.type
)
1179 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1180 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1181 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1183 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1189 /* Generate the loops for a FORALL block. The normal loop format:
1190 count = (end - start + step) / step
1203 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1211 tree var
, start
, end
, step
, mask
, maskindex
;
1214 iter
= forall_tmp
->this_loop
;
1215 for (n
= 0; n
< nvar
; n
++)
1218 start
= iter
->start
;
1222 exit_label
= gfc_build_label_decl (NULL_TREE
);
1223 TREE_USED (exit_label
) = 1;
1225 /* The loop counter. */
1226 count
= gfc_create_var (TREE_TYPE (var
), "count");
1228 /* The body of the loop. */
1229 gfc_init_block (&block
);
1231 /* The exit condition. */
1232 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1233 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1234 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1235 gfc_add_expr_to_block (&block
, tmp
);
1237 /* The main loop body. */
1238 gfc_add_expr_to_block (&block
, body
);
1240 /* Increment the loop variable. */
1241 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1242 gfc_add_modify_expr (&block
, var
, tmp
);
1244 /* Advance to the next mask element. */
1247 mask
= forall_tmp
->mask
;
1248 maskindex
= forall_tmp
->maskindex
;
1251 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1252 maskindex
, gfc_index_one_node
);
1253 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1256 /* Decrement the loop counter. */
1257 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1258 gfc_add_modify_expr (&block
, count
, tmp
);
1260 body
= gfc_finish_block (&block
);
1262 /* Loop var initialization. */
1263 gfc_init_block (&block
);
1264 gfc_add_modify_expr (&block
, var
, start
);
1266 /* Initialize the loop counter. */
1267 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
));
1268 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
));
1269 tmp
= fold (build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
));
1270 gfc_add_modify_expr (&block
, count
, tmp
);
1272 /* The loop expression. */
1273 tmp
= build1_v (LOOP_EXPR
, body
);
1274 gfc_add_expr_to_block (&block
, tmp
);
1276 /* The exit label. */
1277 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1278 gfc_add_expr_to_block (&block
, tmp
);
1280 body
= gfc_finish_block (&block
);
1287 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1288 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1289 nest, otherwise, the body is not controlled by maskes.
1290 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1291 only generate loops for the current forall level. */
1294 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1295 int mask_flag
, int nest_flag
)
1299 forall_info
*forall_tmp
;
1300 tree pmask
, mask
, maskindex
;
1302 forall_tmp
= nested_forall_info
;
1303 /* Generate loops for nested forall. */
1306 while (forall_tmp
->next_nest
!= NULL
)
1307 forall_tmp
= forall_tmp
->next_nest
;
1308 while (forall_tmp
!= NULL
)
1310 /* Generate body with masks' control. */
1313 pmask
= forall_tmp
->pmask
;
1314 mask
= forall_tmp
->mask
;
1315 maskindex
= forall_tmp
->maskindex
;
1319 /* If a mask was specified make the assignment conditional. */
1321 tmp
= gfc_build_indirect_ref (mask
);
1324 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1326 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1329 nvar
= forall_tmp
->nvar
;
1330 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1331 forall_tmp
= forall_tmp
->outer
;
1336 nvar
= forall_tmp
->nvar
;
1337 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1344 /* Allocate data for holding a temporary array. Returns either a local
1345 temporary array or a pointer variable. */
1348 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1356 if (INTEGER_CST_P (size
))
1358 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1359 gfc_index_one_node
));
1364 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1365 type
= build_array_type (elem_type
, type
);
1366 if (gfc_can_put_var_on_stack (bytesize
))
1368 gcc_assert (INTEGER_CST_P (size
));
1369 tmpvar
= gfc_create_var (type
, "temp");
1374 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1375 *pdata
= convert (pvoid_type_node
, tmpvar
);
1377 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1378 if (gfc_index_integer_kind
== 4)
1379 tmp
= gfor_fndecl_internal_malloc
;
1380 else if (gfc_index_integer_kind
== 8)
1381 tmp
= gfor_fndecl_internal_malloc64
;
1384 tmp
= gfc_build_function_call (tmp
, args
);
1385 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1386 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1392 /* Generate codes to copy the temporary to the actual lhs. */
1395 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree size
,
1396 tree count3
, tree count1
, tree count2
, tree wheremask
)
1400 stmtblock_t block
, body
;
1407 lss
= gfc_walk_expr (expr
);
1409 if (lss
== gfc_ss_terminator
)
1411 gfc_start_block (&block
);
1413 gfc_init_se (&lse
, NULL
);
1415 /* Translate the expression. */
1416 gfc_conv_expr (&lse
, expr
);
1418 /* Form the expression for the temporary. */
1419 tmp
= gfc_build_array_ref (tmp1
, count1
);
1421 /* Use the scalar assignment as is. */
1422 gfc_add_block_to_block (&block
, &lse
.pre
);
1423 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1424 gfc_add_block_to_block (&block
, &lse
.post
);
1426 /* Increment the count1. */
1427 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1428 gfc_add_modify_expr (&block
, count1
, tmp
);
1429 tmp
= gfc_finish_block (&block
);
1433 gfc_start_block (&block
);
1435 gfc_init_loopinfo (&loop1
);
1436 gfc_init_se (&rse
, NULL
);
1437 gfc_init_se (&lse
, NULL
);
1439 /* Associate the lss with the loop. */
1440 gfc_add_ss_to_loop (&loop1
, lss
);
1442 /* Calculate the bounds of the scalarization. */
1443 gfc_conv_ss_startstride (&loop1
);
1444 /* Setup the scalarizing loops. */
1445 gfc_conv_loop_setup (&loop1
);
1447 gfc_mark_ss_chain_used (lss
, 1);
1448 /* Initialize count2. */
1449 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1451 /* Start the scalarized loop body. */
1452 gfc_start_scalarized_body (&loop1
, &body
);
1454 /* Setup the gfc_se structures. */
1455 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1458 /* Form the expression of the temporary. */
1459 if (lss
!= gfc_ss_terminator
)
1461 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1463 rse
.expr
= gfc_build_array_ref (tmp1
, index
);
1465 /* Translate expr. */
1466 gfc_conv_expr (&lse
, expr
);
1468 /* Use the scalar assignment. */
1469 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1471 /* Form the mask expression according to the mask tree list. */
1476 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1477 tmp2
= TREE_CHAIN (tmp2
);
1480 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1481 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1482 wheremaskexpr
, tmp1
);
1483 tmp2
= TREE_CHAIN (tmp2
);
1485 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1488 gfc_add_expr_to_block (&body
, tmp
);
1490 /* Increment count2. */
1491 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1492 count2
, gfc_index_one_node
));
1493 gfc_add_modify_expr (&body
, count2
, tmp
);
1495 /* Increment count3. */
1498 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1499 count3
, gfc_index_one_node
));
1500 gfc_add_modify_expr (&body
, count3
, tmp
);
1503 /* Generate the copying loops. */
1504 gfc_trans_scalarizing_loops (&loop1
, &body
);
1505 gfc_add_block_to_block (&block
, &loop1
.pre
);
1506 gfc_add_block_to_block (&block
, &loop1
.post
);
1507 gfc_cleanup_loop (&loop1
);
1509 /* Increment count1. */
1510 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1511 gfc_add_modify_expr (&block
, count1
, tmp
);
1512 tmp
= gfc_finish_block (&block
);
1518 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1519 LSS and RSS are formed in function compute_inner_temp_size(), and should
1523 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree size
,
1524 tree count3
, tree count1
, tree count2
,
1525 gfc_ss
*lss
, gfc_ss
*rss
, tree wheremask
)
1527 stmtblock_t block
, body1
;
1531 tree tmp
, tmp2
, index
;
1534 gfc_start_block (&block
);
1536 gfc_init_se (&rse
, NULL
);
1537 gfc_init_se (&lse
, NULL
);
1539 if (lss
== gfc_ss_terminator
)
1541 gfc_init_block (&body1
);
1542 gfc_conv_expr (&rse
, expr2
);
1543 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1547 /* Initialize count2. */
1548 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1550 /* Initialize the loop. */
1551 gfc_init_loopinfo (&loop
);
1553 /* We may need LSS to determine the shape of the expression. */
1554 gfc_add_ss_to_loop (&loop
, lss
);
1555 gfc_add_ss_to_loop (&loop
, rss
);
1557 gfc_conv_ss_startstride (&loop
);
1558 gfc_conv_loop_setup (&loop
);
1560 gfc_mark_ss_chain_used (rss
, 1);
1561 /* Start the loop body. */
1562 gfc_start_scalarized_body (&loop
, &body1
);
1564 /* Translate the expression. */
1565 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1567 gfc_conv_expr (&rse
, expr2
);
1569 /* Form the expression of the temporary. */
1570 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count1
, count2
));
1571 lse
.expr
= gfc_build_array_ref (tmp1
, index
);
1574 /* Use the scalar assignment. */
1575 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1577 /* Form the mask expression according to the mask tree list. */
1582 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1583 tmp2
= TREE_CHAIN (tmp2
);
1586 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1587 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1588 wheremaskexpr
, tmp1
);
1589 tmp2
= TREE_CHAIN (tmp2
);
1591 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1594 gfc_add_expr_to_block (&body1
, tmp
);
1596 if (lss
== gfc_ss_terminator
)
1598 gfc_add_block_to_block (&block
, &body1
);
1602 /* Increment count2. */
1603 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1604 count2
, gfc_index_one_node
));
1605 gfc_add_modify_expr (&body1
, count2
, tmp
);
1607 /* Increment count3. */
1610 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1611 count3
, gfc_index_one_node
));
1612 gfc_add_modify_expr (&body1
, count3
, tmp
);
1615 /* Generate the copying loops. */
1616 gfc_trans_scalarizing_loops (&loop
, &body1
);
1618 gfc_add_block_to_block (&block
, &loop
.pre
);
1619 gfc_add_block_to_block (&block
, &loop
.post
);
1621 gfc_cleanup_loop (&loop
);
1622 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1623 as tree nodes in SS may not be valid in different scope. */
1625 /* Increment count1. */
1626 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1627 gfc_add_modify_expr (&block
, count1
, tmp
);
1629 tmp
= gfc_finish_block (&block
);
1634 /* Calculate the size of temporary needed in the assignment inside forall.
1635 LSS and RSS are filled in this function. */
1638 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1639 stmtblock_t
* pblock
,
1640 gfc_ss
**lss
, gfc_ss
**rss
)
1647 *lss
= gfc_walk_expr (expr1
);
1650 size
= gfc_index_one_node
;
1651 if (*lss
!= gfc_ss_terminator
)
1653 gfc_init_loopinfo (&loop
);
1655 /* Walk the RHS of the expression. */
1656 *rss
= gfc_walk_expr (expr2
);
1657 if (*rss
== gfc_ss_terminator
)
1659 /* The rhs is scalar. Add a ss for the expression. */
1660 *rss
= gfc_get_ss ();
1661 (*rss
)->next
= gfc_ss_terminator
;
1662 (*rss
)->type
= GFC_SS_SCALAR
;
1663 (*rss
)->expr
= expr2
;
1666 /* Associate the SS with the loop. */
1667 gfc_add_ss_to_loop (&loop
, *lss
);
1668 /* We don't actually need to add the rhs at this point, but it might
1669 make guessing the loop bounds a bit easier. */
1670 gfc_add_ss_to_loop (&loop
, *rss
);
1672 /* We only want the shape of the expression, not rest of the junk
1673 generated by the scalarizer. */
1674 loop
.array_parameter
= 1;
1676 /* Calculate the bounds of the scalarization. */
1677 gfc_conv_ss_startstride (&loop
);
1678 gfc_conv_loop_setup (&loop
);
1680 /* Figure out how many elements we need. */
1681 for (i
= 0; i
< loop
.dimen
; i
++)
1683 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
1684 gfc_index_one_node
, loop
.from
[i
]));
1685 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1687 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
1689 gfc_add_block_to_block (pblock
, &loop
.pre
);
1690 size
= gfc_evaluate_now (size
, pblock
);
1691 gfc_add_block_to_block (pblock
, &loop
.post
);
1693 /* TODO: write a function that cleans up a loopinfo without freeing
1694 the SS chains. Currently a NOP. */
1701 /* Calculate the overall iterator number of the nested forall construct. */
1704 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1710 /* TODO: optimizing the computing process. */
1711 number
= gfc_create_var (gfc_array_index_type
, "num");
1712 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1714 gfc_start_block (&body
);
1715 if (nested_forall_info
)
1716 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1720 gfc_add_modify_expr (&body
, number
, tmp
);
1721 tmp
= gfc_finish_block (&body
);
1723 /* Generate loops. */
1724 if (nested_forall_info
!= NULL
)
1725 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1727 gfc_add_expr_to_block (block
, tmp
);
1733 /* Allocate temporary for forall construct according to the information in
1734 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1735 assignment inside forall. PTEMP1 is returned for space free. */
1738 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1739 tree inner_size
, stmtblock_t
* block
,
1745 tree bytesize
, size
;
1747 /* Calculate the total size of temporary needed in forall construct. */
1748 size
= compute_overall_iter_number (nested_forall_info
, inner_size
, block
);
1750 unit
= TYPE_SIZE_UNIT (type
);
1751 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
));
1754 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1757 tmp
= gfc_build_indirect_ref (temp1
);
1765 /* Handle assignments inside forall which need temporary. */
1767 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1768 forall_info
* nested_forall_info
,
1769 stmtblock_t
* block
)
1774 tree count
, count1
, count2
;
1777 tree mask
, maskindex
;
1778 forall_info
*forall_tmp
;
1780 /* Create vars. count1 is the current iterator number of the nested forall.
1781 count2 is the current iterator number of the inner loops needed in the
1783 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1784 count2
= gfc_create_var (gfc_array_index_type
, "count2");
1786 /* Count is the wheremask index. */
1789 count
= gfc_create_var (gfc_array_index_type
, "count");
1790 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1795 /* Initialize count1. */
1796 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1798 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1799 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1800 inner_size
= compute_inner_temp_size (expr1
, expr2
, block
, &lss
, &rss
);
1802 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1803 type
= gfc_typenode_for_spec (&expr1
->ts
);
1805 /* Allocate temporary for nested forall construct according to the
1806 information in nested_forall_info and inner_size. */
1807 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
1808 inner_size
, block
, &ptemp1
);
1810 /* Initialize the maskindexes. */
1811 forall_tmp
= nested_forall_info
;
1812 while (forall_tmp
!= NULL
)
1814 mask
= forall_tmp
->mask
;
1815 maskindex
= forall_tmp
->maskindex
;
1817 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1818 forall_tmp
= forall_tmp
->next_nest
;
1821 /* Generate codes to copy rhs to the temporary . */
1822 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, inner_size
, count
,
1823 count1
, count2
, lss
, rss
, wheremask
);
1825 /* Generate body and loops according to the information in
1826 nested_forall_info. */
1827 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1828 gfc_add_expr_to_block (block
, tmp
);
1831 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1833 /* Reset maskindexed. */
1834 forall_tmp
= nested_forall_info
;
1835 while (forall_tmp
!= NULL
)
1837 mask
= forall_tmp
->mask
;
1838 maskindex
= forall_tmp
->maskindex
;
1840 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1841 forall_tmp
= forall_tmp
->next_nest
;
1846 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1848 /* Generate codes to copy the temporary to lhs. */
1849 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, inner_size
, count
,
1850 count1
, count2
, wheremask
);
1852 /* Generate body and loops according to the information in
1853 nested_forall_info. */
1854 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1855 gfc_add_expr_to_block (block
, tmp
);
1859 /* Free the temporary. */
1860 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
1861 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
1862 gfc_add_expr_to_block (block
, tmp
);
1867 /* Translate pointer assignment inside FORALL which need temporary. */
1870 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
1871 forall_info
* nested_forall_info
,
1872 stmtblock_t
* block
)
1886 tree tmp
, tmp1
, ptemp1
;
1887 tree mask
, maskindex
;
1888 forall_info
*forall_tmp
;
1890 count
= gfc_create_var (gfc_array_index_type
, "count");
1891 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1893 inner_size
= integer_one_node
;
1894 lss
= gfc_walk_expr (expr1
);
1895 rss
= gfc_walk_expr (expr2
);
1896 if (lss
== gfc_ss_terminator
)
1898 type
= gfc_typenode_for_spec (&expr1
->ts
);
1899 type
= build_pointer_type (type
);
1901 /* Allocate temporary for nested forall construct according to the
1902 information in nested_forall_info and inner_size. */
1903 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
,
1904 type
, inner_size
, block
, &ptemp1
);
1905 gfc_start_block (&body
);
1906 gfc_init_se (&lse
, NULL
);
1907 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
1908 gfc_init_se (&rse
, NULL
);
1909 rse
.want_pointer
= 1;
1910 gfc_conv_expr (&rse
, expr2
);
1911 gfc_add_block_to_block (&body
, &rse
.pre
);
1912 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
1913 gfc_add_block_to_block (&body
, &rse
.post
);
1915 /* Increment count. */
1916 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1917 count
, gfc_index_one_node
));
1918 gfc_add_modify_expr (&body
, count
, tmp
);
1920 tmp
= gfc_finish_block (&body
);
1922 /* Initialize the maskindexes. */
1923 forall_tmp
= nested_forall_info
;
1924 while (forall_tmp
!= NULL
)
1926 mask
= forall_tmp
->mask
;
1927 maskindex
= forall_tmp
->maskindex
;
1929 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1930 forall_tmp
= forall_tmp
->next_nest
;
1933 /* Generate body and loops according to the information in
1934 nested_forall_info. */
1935 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1936 gfc_add_expr_to_block (block
, tmp
);
1939 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1941 /* Reset maskindexes. */
1942 forall_tmp
= nested_forall_info
;
1943 while (forall_tmp
!= NULL
)
1945 mask
= forall_tmp
->mask
;
1946 maskindex
= forall_tmp
->maskindex
;
1948 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1949 forall_tmp
= forall_tmp
->next_nest
;
1951 gfc_start_block (&body
);
1952 gfc_init_se (&lse
, NULL
);
1953 gfc_init_se (&rse
, NULL
);
1954 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
1955 lse
.want_pointer
= 1;
1956 gfc_conv_expr (&lse
, expr1
);
1957 gfc_add_block_to_block (&body
, &lse
.pre
);
1958 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
1959 gfc_add_block_to_block (&body
, &lse
.post
);
1960 /* Increment count. */
1961 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1962 count
, gfc_index_one_node
));
1963 gfc_add_modify_expr (&body
, count
, tmp
);
1964 tmp
= gfc_finish_block (&body
);
1966 /* Generate body and loops according to the information in
1967 nested_forall_info. */
1968 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1969 gfc_add_expr_to_block (block
, tmp
);
1973 gfc_init_loopinfo (&loop
);
1975 /* Associate the SS with the loop. */
1976 gfc_add_ss_to_loop (&loop
, rss
);
1978 /* Setup the scalarizing loops and bounds. */
1979 gfc_conv_ss_startstride (&loop
);
1981 gfc_conv_loop_setup (&loop
);
1983 info
= &rss
->data
.info
;
1984 desc
= info
->descriptor
;
1986 /* Make a new descriptor. */
1987 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
1988 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
1989 loop
.from
, loop
.to
, 1);
1991 /* Allocate temporary for nested forall construct. */
1992 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
1993 inner_size
, block
, &ptemp1
);
1994 gfc_start_block (&body
);
1995 gfc_init_se (&lse
, NULL
);
1996 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
1997 lse
.direct_byref
= 1;
1998 rss
= gfc_walk_expr (expr2
);
1999 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2001 gfc_add_block_to_block (&body
, &lse
.pre
);
2002 gfc_add_block_to_block (&body
, &lse
.post
);
2004 /* Increment count. */
2005 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2006 count
, gfc_index_one_node
));
2007 gfc_add_modify_expr (&body
, count
, tmp
);
2009 tmp
= gfc_finish_block (&body
);
2011 /* Initialize the maskindexes. */
2012 forall_tmp
= nested_forall_info
;
2013 while (forall_tmp
!= NULL
)
2015 mask
= forall_tmp
->mask
;
2016 maskindex
= forall_tmp
->maskindex
;
2018 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2019 forall_tmp
= forall_tmp
->next_nest
;
2022 /* Generate body and loops according to the information in
2023 nested_forall_info. */
2024 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2025 gfc_add_expr_to_block (block
, tmp
);
2028 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2030 /* Reset maskindexes. */
2031 forall_tmp
= nested_forall_info
;
2032 while (forall_tmp
!= NULL
)
2034 mask
= forall_tmp
->mask
;
2035 maskindex
= forall_tmp
->maskindex
;
2037 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2038 forall_tmp
= forall_tmp
->next_nest
;
2040 parm
= gfc_build_array_ref (tmp1
, count
);
2041 lss
= gfc_walk_expr (expr1
);
2042 gfc_init_se (&lse
, NULL
);
2043 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2044 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2045 gfc_start_block (&body
);
2046 gfc_add_block_to_block (&body
, &lse
.pre
);
2047 gfc_add_block_to_block (&body
, &lse
.post
);
2049 /* Increment count. */
2050 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2051 count
, gfc_index_one_node
));
2052 gfc_add_modify_expr (&body
, count
, tmp
);
2054 tmp
= gfc_finish_block (&body
);
2056 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2057 gfc_add_expr_to_block (block
, tmp
);
2059 /* Free the temporary. */
2062 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2063 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2064 gfc_add_expr_to_block (block
, tmp
);
2069 /* FORALL and WHERE statements are really nasty, especially when you nest
2070 them. All the rhs of a forall assignment must be evaluated before the
2071 actual assignments are performed. Presumably this also applies to all the
2072 assignments in an inner where statement. */
2074 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2075 linear array, relying on the fact that we process in the same order in all
2078 forall (i=start:end:stride; maskexpr)
2082 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2084 count = ((end + 1 - start) / staride)
2085 masktmp(:) = maskexpr(:)
2088 for (i = start; i <= end; i += stride)
2090 if (masktmp[maskindex++])
2094 for (i = start; i <= end; i += stride)
2096 if (masktmp[maskindex++])
2100 Note that this code only works when there are no dependencies.
2101 Forall loop with array assignments and data dependencies are a real pain,
2102 because the size of the temporary cannot always be determined before the
2103 loop is executed. This problem is compounded by the presence of nested
2108 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2130 gfc_forall_iterator
*fa
;
2133 gfc_saved_var
*saved_vars
;
2134 iter_info
*this_forall
, *iter_tmp
;
2135 forall_info
*info
, *forall_tmp
;
2136 temporary_list
*temp
;
2138 gfc_start_block (&block
);
2141 /* Count the FORALL index number. */
2142 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2146 /* Allocate the space for var, start, end, step, varexpr. */
2147 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2148 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2149 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2150 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2151 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2152 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2154 /* Allocate the space for info. */
2155 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2157 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2159 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2161 /* allocate space for this_forall. */
2162 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2164 /* Create a temporary variable for the FORALL index. */
2165 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2166 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2167 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2169 /* Record it in this_forall. */
2170 this_forall
->var
= var
[n
];
2172 /* Replace the index symbol's backend_decl with the temporary decl. */
2173 sym
->backend_decl
= var
[n
];
2175 /* Work out the start, end and stride for the loop. */
2176 gfc_init_se (&se
, NULL
);
2177 gfc_conv_expr_val (&se
, fa
->start
);
2178 /* Record it in this_forall. */
2179 this_forall
->start
= se
.expr
;
2180 gfc_add_block_to_block (&block
, &se
.pre
);
2183 gfc_init_se (&se
, NULL
);
2184 gfc_conv_expr_val (&se
, fa
->end
);
2185 /* Record it in this_forall. */
2186 this_forall
->end
= se
.expr
;
2187 gfc_make_safe_expr (&se
);
2188 gfc_add_block_to_block (&block
, &se
.pre
);
2191 gfc_init_se (&se
, NULL
);
2192 gfc_conv_expr_val (&se
, fa
->stride
);
2193 /* Record it in this_forall. */
2194 this_forall
->step
= se
.expr
;
2195 gfc_make_safe_expr (&se
);
2196 gfc_add_block_to_block (&block
, &se
.pre
);
2199 /* Set the NEXT field of this_forall to NULL. */
2200 this_forall
->next
= NULL
;
2201 /* Link this_forall to the info construct. */
2202 if (info
->this_loop
== NULL
)
2203 info
->this_loop
= this_forall
;
2206 iter_tmp
= info
->this_loop
;
2207 while (iter_tmp
->next
!= NULL
)
2208 iter_tmp
= iter_tmp
->next
;
2209 iter_tmp
->next
= this_forall
;
2216 /* Work out the number of elements in the mask array. */
2219 size
= gfc_index_one_node
;
2220 sizevar
= NULL_TREE
;
2222 for (n
= 0; n
< nvar
; n
++)
2224 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2227 /* size = (end + step - start) / step. */
2228 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2229 step
[n
], start
[n
]));
2230 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
));
2232 tmp
= fold (build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]));
2233 tmp
= convert (gfc_array_index_type
, tmp
);
2235 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2238 /* Record the nvar and size of current forall level. */
2242 /* Link the current forall level to nested_forall_info. */
2243 forall_tmp
= nested_forall_info
;
2244 if (forall_tmp
== NULL
)
2245 nested_forall_info
= info
;
2248 while (forall_tmp
->next_nest
!= NULL
)
2249 forall_tmp
= forall_tmp
->next_nest
;
2250 info
->outer
= forall_tmp
;
2251 forall_tmp
->next_nest
= info
;
2254 /* Copy the mask into a temporary variable if required.
2255 For now we assume a mask temporary is needed. */
2258 /* Allocate the mask temporary. */
2259 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2260 TYPE_SIZE_UNIT (boolean_type_node
)));
2262 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2264 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2265 /* Record them in the info structure. */
2266 info
->pmask
= pmask
;
2268 info
->maskindex
= maskindex
;
2270 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2272 /* Start of mask assignment loop body. */
2273 gfc_start_block (&body
);
2275 /* Evaluate the mask expression. */
2276 gfc_init_se (&se
, NULL
);
2277 gfc_conv_expr_val (&se
, code
->expr
);
2278 gfc_add_block_to_block (&body
, &se
.pre
);
2280 /* Store the mask. */
2281 se
.expr
= convert (boolean_type_node
, se
.expr
);
2284 tmp
= gfc_build_indirect_ref (mask
);
2287 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2288 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2290 /* Advance to the next mask element. */
2291 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2292 maskindex
, gfc_index_one_node
);
2293 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2295 /* Generate the loops. */
2296 tmp
= gfc_finish_block (&body
);
2297 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2298 gfc_add_expr_to_block (&block
, tmp
);
2302 /* No mask was specified. */
2303 maskindex
= NULL_TREE
;
2304 mask
= pmask
= NULL_TREE
;
2307 c
= code
->block
->next
;
2309 /* TODO: loop merging in FORALL statements. */
2310 /* Now that we've got a copy of the mask, generate the assignment loops. */
2316 /* A scalar or array assignment. */
2317 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2318 /* Teporaries due to array assignment data dependencies introduce
2319 no end of problems. */
2321 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2322 nested_forall_info
, &block
);
2325 /* Use the normal assignment copying routines. */
2326 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2328 /* Reset the mask index. */
2330 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2332 /* Generate body and loops. */
2333 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2334 gfc_add_expr_to_block (&block
, tmp
);
2341 /* Translate WHERE or WHERE construct nested in FORALL. */
2343 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2350 /* Free the temporary. */
2351 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2352 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2353 gfc_add_expr_to_block (&block
, tmp
);
2362 /* Pointer assignment inside FORALL. */
2363 case EXEC_POINTER_ASSIGN
:
2364 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2366 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2367 nested_forall_info
, &block
);
2370 /* Use the normal assignment copying routines. */
2371 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2373 /* Reset the mask index. */
2375 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2377 /* Generate body and loops. */
2378 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2380 gfc_add_expr_to_block (&block
, tmp
);
2385 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2386 gfc_add_expr_to_block (&block
, tmp
);
2396 /* Restore the original index variables. */
2397 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2398 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2400 /* Free the space for var, start, end, step, varexpr. */
2406 gfc_free (saved_vars
);
2410 /* Free the temporary for the mask. */
2411 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2412 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2413 gfc_add_expr_to_block (&block
, tmp
);
2416 pushdecl (maskindex
);
2418 return gfc_finish_block (&block
);
2422 /* Translate the FORALL statement or construct. */
2424 tree
gfc_trans_forall (gfc_code
* code
)
2426 return gfc_trans_forall_1 (code
, NULL
);
2430 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2431 If the WHERE construct is nested in FORALL, compute the overall temporary
2432 needed by the WHERE mask expression multiplied by the iterator number of
2434 ME is the WHERE mask expression.
2435 MASK is the temporary which value is mask's value.
2436 NMASK is another temporary which value is !mask.
2437 TEMP records the temporary's address allocated in this function in order to
2438 free them outside this function.
2439 MASK, NMASK and TEMP are all OUT arguments. */
2442 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2443 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2444 stmtblock_t
* block
)
2449 tree ptemp1
, ntmp
, ptemp2
;
2451 stmtblock_t body
, body1
;
2456 gfc_init_loopinfo (&loop
);
2458 /* Calculate the size of temporary needed by the mask-expr. */
2459 inner_size
= compute_inner_temp_size (me
, me
, block
, &lss
, &rss
);
2461 /* Allocate temporary for where mask. */
2462 tmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2463 inner_size
, block
, &ptemp1
);
2464 /* Record the temporary address in order to free it later. */
2467 temporary_list
*tempo
;
2468 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2469 tempo
->temporary
= ptemp1
;
2470 tempo
->next
= *temp
;
2474 /* Allocate temporary for !mask. */
2475 ntmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2476 inner_size
, block
, &ptemp2
);
2477 /* Record the temporary in order to free it later. */
2480 temporary_list
*tempo
;
2481 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2482 tempo
->temporary
= ptemp2
;
2483 tempo
->next
= *temp
;
2487 /* Variable to index the temporary. */
2488 count
= gfc_create_var (gfc_array_index_type
, "count");
2489 /* Initialize count. */
2490 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2492 gfc_start_block (&body
);
2494 gfc_init_se (&rse
, NULL
);
2495 gfc_init_se (&lse
, NULL
);
2497 if (lss
== gfc_ss_terminator
)
2499 gfc_init_block (&body1
);
2503 /* Initialize the loop. */
2504 gfc_init_loopinfo (&loop
);
2506 /* We may need LSS to determine the shape of the expression. */
2507 gfc_add_ss_to_loop (&loop
, lss
);
2508 gfc_add_ss_to_loop (&loop
, rss
);
2510 gfc_conv_ss_startstride (&loop
);
2511 gfc_conv_loop_setup (&loop
);
2513 gfc_mark_ss_chain_used (rss
, 1);
2514 /* Start the loop body. */
2515 gfc_start_scalarized_body (&loop
, &body1
);
2517 /* Translate the expression. */
2518 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2520 gfc_conv_expr (&rse
, me
);
2522 /* Form the expression of the temporary. */
2523 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2524 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2526 /* Use the scalar assignment to fill temporary TMP. */
2527 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2528 gfc_add_expr_to_block (&body1
, tmp1
);
2530 /* Fill temporary NTMP. */
2531 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2532 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2534 if (lss
== gfc_ss_terminator
)
2536 gfc_add_block_to_block (&body
, &body1
);
2540 /* Increment count. */
2541 tmp1
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2542 gfc_index_one_node
));
2543 gfc_add_modify_expr (&body1
, count
, tmp1
);
2545 /* Generate the copying loops. */
2546 gfc_trans_scalarizing_loops (&loop
, &body1
);
2548 gfc_add_block_to_block (&body
, &loop
.pre
);
2549 gfc_add_block_to_block (&body
, &loop
.post
);
2551 gfc_cleanup_loop (&loop
);
2552 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2553 as tree nodes in SS may not be valid in different scope. */
2556 tmp1
= gfc_finish_block (&body
);
2557 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2558 if (nested_forall_info
!= NULL
)
2559 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2562 gfc_add_expr_to_block (block
, tmp1
);
2571 /* Translate an assignment statement in a WHERE statement or construct
2572 statement. The MASK expression is used to control which elements
2573 of EXPR1 shall be assigned. */
2576 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2577 tree count1
, tree count2
)
2582 gfc_ss
*lss_section
;
2589 tree index
, maskexpr
, tmp1
;
2592 /* TODO: handle this special case.
2593 Special case a single function returning an array. */
2594 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2596 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2602 /* Assignment of the form lhs = rhs. */
2603 gfc_start_block (&block
);
2605 gfc_init_se (&lse
, NULL
);
2606 gfc_init_se (&rse
, NULL
);
2609 lss
= gfc_walk_expr (expr1
);
2612 /* In each where-assign-stmt, the mask-expr and the variable being
2613 defined shall be arrays of the same shape. */
2614 gcc_assert (lss
!= gfc_ss_terminator
);
2616 /* The assignment needs scalarization. */
2619 /* Find a non-scalar SS from the lhs. */
2620 while (lss_section
!= gfc_ss_terminator
2621 && lss_section
->type
!= GFC_SS_SECTION
)
2622 lss_section
= lss_section
->next
;
2624 gcc_assert (lss_section
!= gfc_ss_terminator
);
2626 /* Initialize the scalarizer. */
2627 gfc_init_loopinfo (&loop
);
2630 rss
= gfc_walk_expr (expr2
);
2631 if (rss
== gfc_ss_terminator
)
2633 /* The rhs is scalar. Add a ss for the expression. */
2634 rss
= gfc_get_ss ();
2635 rss
->next
= gfc_ss_terminator
;
2636 rss
->type
= GFC_SS_SCALAR
;
2640 /* Associate the SS with the loop. */
2641 gfc_add_ss_to_loop (&loop
, lss
);
2642 gfc_add_ss_to_loop (&loop
, rss
);
2644 /* Calculate the bounds of the scalarization. */
2645 gfc_conv_ss_startstride (&loop
);
2647 /* Resolve any data dependencies in the statement. */
2648 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2650 /* Setup the scalarizing loops. */
2651 gfc_conv_loop_setup (&loop
);
2653 /* Setup the gfc_se structures. */
2654 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2655 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2658 gfc_mark_ss_chain_used (rss
, 1);
2659 if (loop
.temp_ss
== NULL
)
2662 gfc_mark_ss_chain_used (lss
, 1);
2666 lse
.ss
= loop
.temp_ss
;
2667 gfc_mark_ss_chain_used (lss
, 3);
2668 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2671 /* Start the scalarized loop body. */
2672 gfc_start_scalarized_body (&loop
, &body
);
2674 /* Translate the expression. */
2675 gfc_conv_expr (&rse
, expr2
);
2676 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2678 gfc_conv_tmp_array_ref (&lse
);
2679 gfc_advance_se_ss_chain (&lse
);
2682 gfc_conv_expr (&lse
, expr1
);
2684 /* Form the mask expression according to the mask tree list. */
2688 maskexpr
= gfc_build_array_ref (tmp
, index
);
2692 tmp
= TREE_CHAIN (tmp
);
2695 tmp1
= gfc_build_array_ref (tmp
, index
);
2696 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2697 tmp
= TREE_CHAIN (tmp
);
2699 /* Use the scalar assignment as is. */
2700 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2701 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2703 gfc_add_expr_to_block (&body
, tmp
);
2705 if (lss
== gfc_ss_terminator
)
2707 /* Increment count1. */
2708 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2709 count1
, gfc_index_one_node
));
2710 gfc_add_modify_expr (&body
, count1
, tmp
);
2712 /* Use the scalar assignment as is. */
2713 gfc_add_block_to_block (&block
, &body
);
2717 gcc_assert (lse
.ss
== gfc_ss_terminator
2718 && rse
.ss
== gfc_ss_terminator
);
2720 if (loop
.temp_ss
!= NULL
)
2722 /* Increment count1 before finish the main body of a scalarized
2724 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2725 count1
, gfc_index_one_node
));
2726 gfc_add_modify_expr (&body
, count1
, tmp
);
2727 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2729 /* We need to copy the temporary to the actual lhs. */
2730 gfc_init_se (&lse
, NULL
);
2731 gfc_init_se (&rse
, NULL
);
2732 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2733 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2735 rse
.ss
= loop
.temp_ss
;
2738 gfc_conv_tmp_array_ref (&rse
);
2739 gfc_advance_se_ss_chain (&rse
);
2740 gfc_conv_expr (&lse
, expr1
);
2742 gcc_assert (lse
.ss
== gfc_ss_terminator
2743 && rse
.ss
== gfc_ss_terminator
);
2745 /* Form the mask expression according to the mask tree list. */
2749 maskexpr
= gfc_build_array_ref (tmp
, index
);
2753 tmp
= TREE_CHAIN (tmp
);
2756 tmp1
= gfc_build_array_ref (tmp
, index
);
2757 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2759 tmp
= TREE_CHAIN (tmp
);
2761 /* Use the scalar assignment as is. */
2762 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2763 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2764 gfc_add_expr_to_block (&body
, tmp
);
2766 /* Increment count2. */
2767 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2768 count2
, gfc_index_one_node
));
2769 gfc_add_modify_expr (&body
, count2
, tmp
);
2773 /* Increment count1. */
2774 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2775 count1
, gfc_index_one_node
));
2776 gfc_add_modify_expr (&body
, count1
, tmp
);
2779 /* Generate the copying loops. */
2780 gfc_trans_scalarizing_loops (&loop
, &body
);
2782 /* Wrap the whole thing up. */
2783 gfc_add_block_to_block (&block
, &loop
.pre
);
2784 gfc_add_block_to_block (&block
, &loop
.post
);
2785 gfc_cleanup_loop (&loop
);
2788 return gfc_finish_block (&block
);
2792 /* Translate the WHERE construct or statement.
2793 This fuction can be called iteratively to translate the nested WHERE
2794 construct or statement.
2795 MASK is the control mask, and PMASK is the pending control mask.
2796 TEMP records the temporary address which must be freed later. */
2799 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2800 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2801 temporary_list
** temp
)
2807 tree tmp
, tmp1
, tmp2
;
2808 tree count1
, count2
;
2812 /* the WHERE statement or the WHERE construct statement. */
2813 cblock
= code
->block
;
2816 /* Has mask-expr. */
2819 /* Ensure that the WHERE mask be evaluated only once. */
2820 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2821 &tmp
, &tmp1
, temp
, block
);
2823 /* Set the control mask and the pending control mask. */
2824 /* It's a where-stmt. */
2830 /* It's a nested where-stmt. */
2831 else if (mask
&& pmask
== NULL
)
2834 /* Use the TREE_CHAIN to list the masks. */
2835 tmp2
= copy_list (mask
);
2836 pmask
= chainon (mask
, tmp1
);
2837 mask
= chainon (tmp2
, tmp
);
2839 /* It's a masked-elsewhere-stmt. */
2840 else if (mask
&& cblock
->expr
)
2843 tmp2
= copy_list (pmask
);
2846 tmp2
= chainon (tmp2
, tmp
);
2847 pmask
= chainon (mask
, tmp1
);
2851 /* It's a elsewhere-stmt. No mask-expr is present. */
2855 /* Get the assignment statement of a WHERE statement, or the first
2856 statement in where-body-construct of a WHERE construct. */
2857 cnext
= cblock
->next
;
2862 /* WHERE assignment statement. */
2864 expr1
= cnext
->expr
;
2865 expr2
= cnext
->expr2
;
2866 if (nested_forall_info
!= NULL
)
2871 nvar
= nested_forall_info
->nvar
;
2872 varexpr
= (gfc_expr
**)
2873 gfc_getmem (nvar
* sizeof (gfc_expr
*));
2874 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
2877 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
2878 nested_forall_info
, block
);
2881 /* Variables to control maskexpr. */
2882 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2883 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2884 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2885 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2887 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2889 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
2891 gfc_add_expr_to_block (block
, tmp
);
2896 /* Variables to control maskexpr. */
2897 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2898 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2899 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2900 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2902 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2904 gfc_add_expr_to_block (block
, tmp
);
2909 /* WHERE or WHERE construct is part of a where-body-construct. */
2911 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
2912 mask_copy
= copy_list (mask
);
2913 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
2921 /* The next statement within the same where-body-construct. */
2922 cnext
= cnext
->next
;
2924 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
2925 cblock
= cblock
->block
;
2930 /* As the WHERE or WHERE construct statement can be nested, we call
2931 gfc_trans_where_2 to do the translation, and pass the initial
2932 NULL values for both the control mask and the pending control mask. */
2935 gfc_trans_where (gfc_code
* code
)
2938 temporary_list
*temp
, *p
;
2942 gfc_start_block (&block
);
2945 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
2947 /* Add calls to free temporaries which were dynamically allocated. */
2950 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2951 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2952 gfc_add_expr_to_block (&block
, tmp
);
2958 return gfc_finish_block (&block
);
2962 /* CYCLE a DO loop. The label decl has already been created by
2963 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
2964 node at the head of the loop. We must mark the label as used. */
2967 gfc_trans_cycle (gfc_code
* code
)
2971 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
2972 TREE_USED (cycle_label
) = 1;
2973 return build1_v (GOTO_EXPR
, cycle_label
);
2977 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
2978 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
2982 gfc_trans_exit (gfc_code
* code
)
2986 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
2987 TREE_USED (exit_label
) = 1;
2988 return build1_v (GOTO_EXPR
, exit_label
);
2992 /* Translate the ALLOCATE statement. */
2995 gfc_trans_allocate (gfc_code
* code
)
3008 if (!code
->ext
.alloc_list
)
3011 gfc_start_block (&block
);
3015 tree gfc_int4_type_node
= gfc_get_int_type (4);
3017 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3018 pstat
= gfc_build_addr_expr (NULL
, stat
);
3020 error_label
= gfc_build_label_decl (NULL_TREE
);
3021 TREE_USED (error_label
) = 1;
3025 pstat
= integer_zero_node
;
3026 stat
= error_label
= NULL_TREE
;
3030 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3034 gfc_init_se (&se
, NULL
);
3035 gfc_start_block (&se
.pre
);
3037 se
.want_pointer
= 1;
3038 se
.descriptor_only
= 1;
3039 gfc_conv_expr (&se
, expr
);
3043 /* Find the last reference in the chain. */
3044 while (ref
&& ref
->next
!= NULL
)
3046 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3050 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3053 gfc_array_allocate (&se
, ref
, pstat
);
3057 /* A scalar or derived type. */
3060 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3061 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3062 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3064 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3065 parm
= gfc_chainon_list (NULL_TREE
, val
);
3066 parm
= gfc_chainon_list (parm
, tmp
);
3067 parm
= gfc_chainon_list (parm
, pstat
);
3068 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3069 gfc_add_expr_to_block (&se
.pre
, tmp
);
3073 tmp
= build1_v (GOTO_EXPR
, error_label
);
3075 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3076 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3077 gfc_add_expr_to_block (&se
.pre
, tmp
);
3081 tmp
= gfc_finish_block (&se
.pre
);
3082 gfc_add_expr_to_block (&block
, tmp
);
3085 /* Assign the value to the status variable. */
3088 tmp
= build1_v (LABEL_EXPR
, error_label
);
3089 gfc_add_expr_to_block (&block
, tmp
);
3091 gfc_init_se (&se
, NULL
);
3092 gfc_conv_expr_lhs (&se
, code
->expr
);
3093 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3094 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3097 return gfc_finish_block (&block
);
3102 gfc_trans_deallocate (gfc_code
* code
)
3112 gfc_start_block (&block
);
3114 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3117 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3119 gfc_init_se (&se
, NULL
);
3120 gfc_start_block (&se
.pre
);
3122 se
.want_pointer
= 1;
3123 se
.descriptor_only
= 1;
3124 gfc_conv_expr (&se
, expr
);
3126 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3128 tmp
= gfc_array_deallocate (se
.expr
);
3129 gfc_add_expr_to_block (&se
.pre
, tmp
);
3133 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3134 var
= gfc_create_var (type
, "ptr");
3135 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3136 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3138 tmp
= gfc_chainon_list (NULL_TREE
, var
);
3139 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
3140 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
3141 gfc_add_expr_to_block (&se
.pre
, tmp
);
3143 tmp
= gfc_finish_block (&se
.pre
);
3144 gfc_add_expr_to_block (&block
, tmp
);
3147 return gfc_finish_block (&block
);