/* Statement translation -- generate GCC trees from gfc_code.
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "coretypes.h"
#include "tree.h"
#include "tree-gimple.h"
-#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
-#include <gmp.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}
+
+/* Given a variable expression which has been ASSIGNed to, find the decl
+ containing the auxiliary variables. For variables in common blocks this
+ is a field_decl. */
+
+void
+gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
+{
+ gcc_assert (expr->symtree->n.sym->attr.assign == 1);
+ gfc_conv_expr (se, expr);
+ /* Deals with variable in common block. Get the field declaration. */
+ if (TREE_CODE (se->expr) == COMPONENT_REF)
+ se->expr = TREE_OPERAND (se->expr, 1);
+}
+
/* Translate a label assignment statement. */
+
tree
gfc_trans_label_assign (gfc_code * code)
{
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
- gfc_conv_expr (&se, code->expr);
+ gfc_conv_label_variable (&se, code->expr);
+
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
label_len = code->label->format->value.character.length;
len_tree = build_int_cst (NULL_TREE, label_len);
label_tree = gfc_build_string_const (label_len + 1, label_str);
- label_tree = gfc_build_addr_expr (pchar_type_node, label_tree);
+ label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
}
gfc_add_modify_expr (&se.pre, len, len_tree);
/* ASSIGNED GOTO. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
- gfc_conv_expr (&se, code->expr);
+ gfc_conv_label_variable (&se, code->expr);
assign_error =
gfc_build_cstring_const ("Assigned label is not a target label");
tmp = GFC_DECL_STRING_LEN (se.expr);
}
+/* Translate the simple DO construct. This is where the loop variable has
+ integer type and step +-1. We can't use this in the general case
+ because integer overflow and floating point errors could give incorrect
+ results.
+ We translate a do loop from:
+
+ DO dovar = from, to, step
+ body
+ END DO
+
+ to:
+
+ [Evaluate loop bounds and step]
+ dovar = from;
+ if ((step > 0) ? (dovar <= to) : (dovar => to))
+ {
+ for (;;)
+ {
+ body;
+ cycle_label:
+ cond = (dovar == to);
+ dovar += step;
+ if (cond) goto end_label;
+ }
+ }
+ end_label:
+
+ This helps the optimizers by avoiding the extra induction variable
+ used in the general case. */
+
+static tree
+gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
+ tree from, tree to, tree step)
+{
+ stmtblock_t body;
+ tree type;
+ tree cond;
+ tree tmp;
+ tree cycle_label;
+ tree exit_label;
+
+ type = TREE_TYPE (dovar);
+
+ /* Initialize the DO variable: dovar = from. */
+ gfc_add_modify_expr (pblock, dovar, from);
+
+ /* Cycle and exit statements are implemented with gotos. */
+ cycle_label = gfc_build_label_decl (NULL_TREE);
+ exit_label = gfc_build_label_decl (NULL_TREE);
+
+ /* Put the labels where they can be found later. See gfc_trans_do(). */
+ code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
+
+ /* Loop body. */
+ gfc_start_block (&body);
+
+ /* Main loop body. */
+ tmp = gfc_trans_code (code->block->next);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Label for cycle statements (if needed). */
+ if (TREE_USED (cycle_label))
+ {
+ tmp = build1_v (LABEL_EXPR, cycle_label);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* Evaluate the loop condition. */
+ cond = build2 (EQ_EXPR, boolean_type_node, dovar, to);
+ cond = gfc_evaluate_now (cond, &body);
+
+ /* Increment the loop variable. */
+ tmp = build2 (PLUS_EXPR, type, dovar, step);
+ gfc_add_modify_expr (&body, dovar, tmp);
+
+ /* The loop exit. */
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ TREE_USED (exit_label) = 1;
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Finish the loop body. */
+ tmp = gfc_finish_block (&body);
+ tmp = build1_v (LOOP_EXPR, tmp);
+
+ /* Only execute the loop if the number of iterations is positive. */
+ if (tree_int_cst_sgn (step) > 0)
+ cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
+ else
+ cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (pblock, tmp);
+
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (pblock, tmp);
+
+ return gfc_finish_block (pblock);
+}
+
/* Translate the DO construct. This obviously is one of the most
important ones to get right with any compiler, but especially
so for Fortran.
- Currently we calculate the loop count before entering the loop, but
- it may be possible to optimize if step is a constant. The main
- advantage is that the loop test is a single GENERIC node
+ We special case some loop forms as described in gfc_trans_simple_do.
+ For other cases we implement them with a separate loop count,
+ as described in the standard.
We translate a do loop from:
to:
- pre_dovar;
- pre_from;
- pre_to;
- pre_step;
- temp1=to_expr-from_expr;
- step_temp=step_expr;
- range_temp=step_tmp/range_temp;
- for ( ; range_temp > 0 ; range_temp = range_temp - 1)
+ [evaluate loop bounds and step]
+ count = to + step - from;
+ dovar = from;
+ for (;;)
{
body;
cycle_label:
- dovar_temp = dovar
- dovar=dovar_temp + step_temp;
+ dovar += step
+ count--;
+ if (count <=0) goto exit_label;
}
exit_label:
- Some optimization is done for empty do loops. We can't just let
- dovar=to because it's possible for from+range*loopcount!=to. Anyone
- who writes empty DO deserves sub-optimal (but correct) code anyway.
-
TODO: Large loop counts
- Does not work loop counts which do not fit into a signed integer kind,
+ The code above assumes the loop count fits into a signed integer kind,
i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
We must support the full range. */
tree to;
tree step;
tree count;
+ tree count_one;
tree type;
tree cond;
tree cycle_label;
gfc_start_block (&block);
- /* Create GIMPLE versions of all expressions in the iterator. */
-
+ /* Evaluate all the expressions in the iterator. */
gfc_init_se (&se, NULL);
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
gfc_add_block_to_block (&block, &se.pre);
type = TREE_TYPE (dovar);
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, code->ext.iterator->start, type);
+ gfc_conv_expr_val (&se, code->ext.iterator->start);
gfc_add_block_to_block (&block, &se.pre);
- from = se.expr;
+ from = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, code->ext.iterator->end, type);
+ gfc_conv_expr_val (&se, code->ext.iterator->end);
gfc_add_block_to_block (&block, &se.pre);
- to = se.expr;
+ to = gfc_evaluate_now (se.expr, &block);
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, code->ext.iterator->step, type);
-
- /* We don't want this changing part way through. */
- gfc_make_safe_expr (&se);
+ gfc_conv_expr_val (&se, code->ext.iterator->step);
gfc_add_block_to_block (&block, &se.pre);
- step = se.expr;
-
+ step = gfc_evaluate_now (se.expr, &block);
+
+ /* Special case simple loops. */
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && (integer_onep (step)
+ || tree_int_cst_equal (step, integer_minus_one_node)))
+ return gfc_trans_simple_do (code, &block, dovar, from, to, step);
+
/* Initialize loop count. This code is executed before we enter the
loop body. We generate: count = (to + step - from) / step. */
- tmp = fold (build2 (MINUS_EXPR, type, step, from));
- tmp = fold (build2 (PLUS_EXPR, type, to, tmp));
- tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step));
-
- count = gfc_create_var (type, "count");
+ tmp = fold_build2 (MINUS_EXPR, type, step, from);
+ tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
+ if (TREE_CODE (type) == INTEGER_TYPE)
+ {
+ tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
+ count = gfc_create_var (type, "count");
+ }
+ else
+ {
+ /* TODO: We could use the same width as the real type.
+ This would probably cause more problems that it solves
+ when we implement "long double" types. */
+ tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
+ tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
+ count = gfc_create_var (gfc_array_index_type, "count");
+ }
gfc_add_modify_expr (&block, count, tmp);
+ count_one = convert (TREE_TYPE (count), integer_one_node);
+
/* Initialize the DO variable: dovar = from. */
gfc_add_modify_expr (&block, dovar, from);
exit_label = gfc_build_label_decl (NULL_TREE);
/* Start with the loop condition. Loop until count <= 0. */
- cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node);
+ cond = build2 (LE_EXPR, boolean_type_node, count,
+ convert (TREE_TYPE (count), integer_zero_node));
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_modify_expr (&body, dovar, tmp);
/* Decrement the loop count. */
- tmp = build2 (MINUS_EXPR, type, count, gfc_index_one_node);
+ tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
gfc_add_modify_expr (&body, count, tmp);
/* End of loop body. */
gfc_init_se (&cond, NULL);
gfc_conv_expr_val (&cond, code->expr);
gfc_add_block_to_block (&block, &cond.pre);
- cond.expr = fold (build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr));
+ cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
/* Build "IF (! cond) GOTO exit_label". */
tmp = build1_v (GOTO_EXPR, exit_label);
}
/* Build a label. */
- label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
- DECL_CONTEXT (label) = current_function_decl;
+ label = gfc_build_label_decl (NULL_TREE);
/* Add this case label.
Add parameter 'label', make it match GCC backend. */
gfc_add_modify_expr (&block, var, start);
/* Initialize the loop counter. */
- tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (var), step, start));
- tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp));
- tmp = fold (build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step));
+ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
+ tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
gfc_add_modify_expr (&block, count, tmp);
/* The loop expression. */
if (INTEGER_CST_P (size))
{
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, size,
- gfc_index_one_node));
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
}
else
tmp = NULL_TREE;
/* Generate codes to copy the temporary to the actual lhs. */
static tree
-generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
- tree count3, tree count1, tree count2, tree wheremask)
+generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
+ tree count1, tree wheremask)
{
gfc_ss *lss;
gfc_se lse, rse;
stmtblock_t block, body;
gfc_loopinfo loop1;
tree tmp, tmp2;
- tree index;
tree wheremaskexpr;
/* Walk the lhs. */
gfc_add_block_to_block (&block, &lse.post);
/* Increment the count1. */
- tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
+ gfc_index_one_node);
gfc_add_modify_expr (&block, count1, tmp);
+
tmp = gfc_finish_block (&block);
}
else
gfc_conv_loop_setup (&loop1);
gfc_mark_ss_chain_used (lss, 1);
- /* Initialize count2. */
- gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop1, &body);
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
- {
- index = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count1, count2));
- rse.expr = gfc_build_array_ref (tmp1, index);
- }
+ rse.expr = gfc_build_array_ref (tmp1, count1);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- tmp2 = wheremask;
- if (tmp2 != NULL)
- wheremaskexpr = gfc_build_array_ref (tmp2, count3);
- tmp2 = TREE_CHAIN (tmp2);
- while (tmp2)
- {
- tmp1 = gfc_build_array_ref (tmp2, count3);
- wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+ tmp2 = TREE_CHAIN (wheremask);
+ while (tmp2)
+ {
+ tmp1 = gfc_build_array_ref (tmp2, count3);
+ wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
wheremaskexpr, tmp1);
- tmp2 = TREE_CHAIN (tmp2);
- }
- tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
+ tmp2 = TREE_CHAIN (tmp2);
+ }
+ tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
}
gfc_add_expr_to_block (&body, tmp);
- /* Increment count2. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count2, gfc_index_one_node));
- gfc_add_modify_expr (&body, count2, tmp);
+ /* Increment count1. */
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
+ gfc_add_modify_expr (&body, count1, tmp);
/* Increment count3. */
if (count3)
- {
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count3, gfc_index_one_node));
- gfc_add_modify_expr (&body, count3, tmp);
- }
+ {
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count3, gfc_index_one_node);
+ gfc_add_modify_expr (&body, count3, tmp);
+ }
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop1, &body);
gfc_add_block_to_block (&block, &loop1.post);
gfc_cleanup_loop (&loop1);
- /* Increment count1. */
- tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
- gfc_add_modify_expr (&block, count1, tmp);
tmp = gfc_finish_block (&block);
}
return tmp;
not be freed. */
static tree
-generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
- tree count3, tree count1, tree count2,
- gfc_ss *lss, gfc_ss *rss, tree wheremask)
+generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
+ tree count1, gfc_ss *lss, gfc_ss *rss,
+ tree wheremask)
{
stmtblock_t block, body1;
gfc_loopinfo loop;
gfc_se lse;
gfc_se rse;
- tree tmp, tmp2, index;
+ tree tmp, tmp2;
tree wheremaskexpr;
gfc_start_block (&block);
}
else
{
- /* Initialize count2. */
- gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
-
/* Initialize the loop. */
gfc_init_loopinfo (&loop);
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
- index = fold (build2 (PLUS_EXPR, gfc_array_index_type, count1, count2));
- lse.expr = gfc_build_array_ref (tmp1, index);
+ lse.expr = gfc_build_array_ref (tmp1, count1);
}
/* Use the scalar assignment. */
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- tmp2 = wheremask;
- if (tmp2 != NULL)
- wheremaskexpr = gfc_build_array_ref (tmp2, count3);
- tmp2 = TREE_CHAIN (tmp2);
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+ tmp2 = TREE_CHAIN (wheremask);
while (tmp2)
- {
- tmp1 = gfc_build_array_ref (tmp2, count3);
- wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
+ {
+ tmp1 = gfc_build_array_ref (tmp2, count3);
+ wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
wheremaskexpr, tmp1);
- tmp2 = TREE_CHAIN (tmp2);
- }
+ tmp2 = TREE_CHAIN (tmp2);
+ }
tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
}
if (lss == gfc_ss_terminator)
{
gfc_add_block_to_block (&block, &body1);
+
+ /* Increment count1. */
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
+ gfc_index_one_node);
+ gfc_add_modify_expr (&block, count1, tmp);
}
else
{
- /* Increment count2. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count2, gfc_index_one_node));
- gfc_add_modify_expr (&body1, count2, tmp);
+ /* Increment count1. */
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
+ gfc_add_modify_expr (&body1, count1, tmp);
/* Increment count3. */
if (count3)
- {
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count3, gfc_index_one_node));
- gfc_add_modify_expr (&body1, count3, tmp);
- }
+ {
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count3, gfc_index_one_node);
+ gfc_add_modify_expr (&body1, count3, tmp);
+ }
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop, &body1);
gfc_cleanup_loop (&loop);
/* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
- as tree nodes in SS may not be valid in different scope. */
+ as tree nodes in SS may not be valid in different scope. */
}
- /* Increment count1. */
- tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
- gfc_add_modify_expr (&block, count1, tmp);
tmp = gfc_finish_block (&block);
return tmp;
/* Figure out how many elements we need. */
for (i = 0; i < loop.dimen; i++)
{
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[i]));
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- tmp, loop.to[i]));
- size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[i]);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, loop.to[i]);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
}
gfc_add_block_to_block (pblock, &loop.pre);
size = gfc_evaluate_now (size, pblock);
static tree
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
- stmtblock_t *block)
+ stmtblock_t *inner_size_body, stmtblock_t *block)
{
tree tmp, number;
stmtblock_t body;
gfc_add_modify_expr (block, number, gfc_index_zero_node);
gfc_start_block (&body);
+ if (inner_size_body)
+ gfc_add_block_to_block (&body, inner_size_body);
if (nested_forall_info)
tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
inner_size);
}
-/* Allocate temporary for forall construct according to the information in
- nested_forall_info. INNER_SIZE is the size of temporary needed in the
- assignment inside forall. PTEMP1 is returned for space free. */
+/* Allocate temporary for forall construct. SIZE is the size of temporary
+ needed. PTEMP1 is returned for space free. */
static tree
-allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
- tree inner_size, stmtblock_t * block,
- tree * ptemp1)
+allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
+ tree * ptemp1)
{
tree unit;
tree temp1;
tree tmp;
- tree bytesize, size;
-
- /* Calculate the total size of temporary needed in forall construct. */
- size = compute_overall_iter_number (nested_forall_info, inner_size, block);
+ tree bytesize;
unit = TYPE_SIZE_UNIT (type);
- bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size, unit));
+ bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
*ptemp1 = NULL;
temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
}
-/* Handle assignments inside forall which need temporary. */
+/* Allocate temporary for forall construct according to the information in
+ nested_forall_info. INNER_SIZE is the size of temporary needed in the
+ assignment inside forall. PTEMP1 is returned for space free. */
+
+static tree
+allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
+ tree inner_size, stmtblock_t * inner_size_body,
+ stmtblock_t * block, tree * ptemp1)
+{
+ tree size;
+
+ /* Calculate the total size of temporary needed in forall construct. */
+ size = compute_overall_iter_number (nested_forall_info, inner_size,
+ inner_size_body, block);
+
+ return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
+}
+
+
+/* Handle assignments inside forall which need temporary.
+
+ forall (i=start:end:stride; maskexpr)
+ e<i> = f<i>
+ end forall
+ (where e,f<i> are arbitrary expressions possibly involving i
+ and there is a dependency between e<i> and f<i>)
+ Translates to:
+ masktmp(:) = maskexpr(:)
+
+ maskindex = 0;
+ count1 = 0;
+ num = 0;
+ for (i = start; i <= end; i += stride)
+ num += SIZE (f<i>)
+ count1 = 0;
+ ALLOCATE (tmp(num))
+ for (i = start; i <= end; i += stride)
+ {
+ if (masktmp[maskindex++])
+ tmp[count1++] = f<i>
+ }
+ maskindex = 0;
+ count1 = 0;
+ for (i = start; i <= end; i += stride)
+ {
+ if (masktmp[maskindex++])
+ e<i> = tmp[count1++]
+ }
+ DEALLOCATE (tmp)
+ */
static void
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
forall_info * nested_forall_info,
tree type;
tree inner_size;
gfc_ss *lss, *rss;
- tree count, count1, count2;
+ tree count, count1;
tree tmp, tmp1;
tree ptemp1;
tree mask, maskindex;
forall_info *forall_tmp;
+ stmtblock_t inner_size_body;
- /* Create vars. count1 is the current iterator number of the nested forall.
- count2 is the current iterator number of the inner loops needed in the
- assignment. */
+ /* Create vars. count1 is the current iterator number of the nested
+ forall. */
count1 = gfc_create_var (gfc_array_index_type, "count1");
- count2 = gfc_create_var (gfc_array_index_type, "count2");
/* Count is the wheremask index. */
if (wheremask)
/* Calculate the size of temporary needed in the assignment. Return loop, lss
and rss which are used in function generate_loop_for_rhs_to_temp(). */
- inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
+ gfc_init_block (&inner_size_body);
+ inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
+ &lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
type = gfc_typenode_for_spec (&expr1->ts);
/* Allocate temporary for nested forall construct according to the
- information in nested_forall_info and inner_size. */
- tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
- inner_size, block, &ptemp1);
+ information in nested_forall_info and inner_size. */
+ tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
+ &inner_size_body, block, &ptemp1);
/* Initialize the maskindexes. */
forall_tmp = nested_forall_info;
}
/* Generate codes to copy rhs to the temporary . */
- tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
- count1, count2, lss, rss, wheremask);
+ tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
+ wheremask);
/* Generate body and loops according to the information in
nested_forall_info. */
gfc_add_modify_expr (block, count, gfc_index_zero_node);
/* Generate codes to copy the temporary to lhs. */
- tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
- count1, count2, wheremask);
+ tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, wheremask);
/* Generate body and loops according to the information in
nested_forall_info. */
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
- tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
- type, inner_size, block, &ptemp1);
+ tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
+ inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
gfc_add_block_to_block (&body, &rse.post);
/* Increment count. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
gfc_add_modify_expr (&body, lse.expr, rse.expr);
gfc_add_block_to_block (&body, &lse.post);
/* Increment count. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
/* Allocate temporary for nested forall construct. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
- inner_size, block, &ptemp1);
+ inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
lse.expr = gfc_build_array_ref (tmp1, count);
gfc_add_block_to_block (&body, &lse.post);
/* Increment count. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
gfc_add_block_to_block (&body, &lse.post);
/* Increment count. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count, gfc_index_one_node);
gfc_add_modify_expr (&body, count, tmp);
tmp = gfc_finish_block (&body);
e<i> = f<i>
g<i> = h<i>
end forall
- (where e,f,g,h<i> are arbitary expressions possibly involving i)
+ (where e,f,g,h<i> are arbitrary expressions possibly involving i)
Translates to:
- count = ((end + 1 - start) / staride)
+ count = ((end + 1 - start) / stride)
masktmp(:) = maskexpr(:)
maskindex = 0;
for (i = start; i <= end; i += stride)
{
if (masktmp[maskindex++])
- e<i> = f<i>
+ g<i> = h<i>
}
Note that this code only works when there are no dependencies.
lenvar = NULL_TREE;
/* size = (end + step - start) / step. */
- tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (start[n]),
- step[n], start[n]));
- tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
+ tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
+ step[n], start[n]);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
- tmp = fold (build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
+ tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
tmp = convert (gfc_array_index_type, tmp);
- size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
}
/* Record the nvar and size of current forall level. */
}
/* Copy the mask into a temporary variable if required.
- For now we assume a mask temporary is needed. */
+ For now we assume a mask temporary is needed. */
if (code->expr)
{
/* Allocate the mask temporary. */
- bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size,
- TYPE_SIZE_UNIT (boolean_type_node)));
+ bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ TYPE_SIZE_UNIT (boolean_type_node));
mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
case EXEC_ASSIGN:
/* A scalar or array assignment. */
need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
- /* Teporaries due to array assignment data dependencies introduce
+ /* Temporaries due to array assignment data dependencies introduce
no end of problems. */
if (need_temp)
gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
gfc_ss *lss, *rss;
gfc_loopinfo loop;
tree ptemp1, ntmp, ptemp2;
- tree inner_size;
- stmtblock_t body, body1;
+ tree inner_size, size;
+ stmtblock_t body, body1, inner_size_body;
gfc_se lse, rse;
tree count;
tree tmpexpr;
gfc_init_loopinfo (&loop);
/* Calculate the size of temporary needed by the mask-expr. */
- inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
+ gfc_init_block (&inner_size_body);
+ inner_size = compute_inner_temp_size (me, me, &inner_size_body, &lss, &rss);
+
+ /* Calculate the total size of temporary needed. */
+ size = compute_overall_iter_number (nested_forall_info, inner_size,
+ &inner_size_body, block);
/* Allocate temporary for where mask. */
- tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
- inner_size, block, &ptemp1);
+ tmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
+ &ptemp1);
/* Record the temporary address in order to free it later. */
if (ptemp1)
{
}
/* Allocate temporary for !mask. */
- ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
- inner_size, block, &ptemp2);
+ ntmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
+ &ptemp2);
/* Record the temporary in order to free it later. */
if (ptemp2)
{
else
{
/* Increment count. */
- tmp1 = fold (build2 (PLUS_EXPR, gfc_array_index_type, count,
- gfc_index_one_node));
+ tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
+ gfc_index_one_node);
gfc_add_modify_expr (&body1, count, tmp1);
/* Generate the copying loops. */
tmp1 = gfc_finish_block (&body);
/* If the WHERE construct is inside FORALL, fill the full temporary. */
if (nested_forall_info != NULL)
- tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
+ {
+ forall_info *forall_tmp;
+ tree maskindex;
+ /* Initialize the maskindexes. */
+ forall_tmp = nested_forall_info;
+ while (forall_tmp != NULL)
+ {
+ maskindex = forall_tmp->maskindex;
+ if (forall_tmp->mask)
+ gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
+ forall_tmp = forall_tmp->next_nest;
+ }
+
+ tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
+ }
gfc_add_expr_to_block (block, tmp1);
if (lss == gfc_ss_terminator)
{
/* Increment count1. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count1, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
/* Use the scalar assignment as is. */
{
/* Increment count1 before finish the main body of a scalarized
expression. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count1, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
gfc_trans_scalarized_loop_boundary (&loop, &body);
gfc_add_expr_to_block (&body, tmp);
/* Increment count2. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count2, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count2, gfc_index_one_node);
gfc_add_modify_expr (&body, count2, tmp);
}
else
{
/* Increment count1. */
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
- count1, gfc_index_one_node));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ count1, gfc_index_one_node);
gfc_add_modify_expr (&body, count1, tmp);
}
/* Translate the WHERE construct or statement.
- This fuction can be called iteratively to translate the nested WHERE
+ This function can be called iteratively to translate the nested WHERE
construct or statement.
MASK is the control mask, and PMASK is the pending control mask.
TEMP records the temporary address which must be freed later. */
nested_forall_info, block);
else
{
+ forall_info *forall_tmp;
+ tree maskindex;
+
/* Variables to control maskexpr. */
count1 = gfc_create_var (gfc_array_index_type, "count1");
count2 = gfc_create_var (gfc_array_index_type, "count2");
tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
count2);
+
+ /* Initialize the maskindexes. */
+ forall_tmp = nested_forall_info;
+ while (forall_tmp != NULL)
+ {
+ maskindex = forall_tmp->maskindex;
+ if (forall_tmp->mask)
+ gfc_add_modify_expr (block, maskindex,
+ gfc_index_zero_node);
+ forall_tmp = forall_tmp->next_nest;
+ }
+
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1, 1);
gfc_add_expr_to_block (block, tmp);
/* As the WHERE or WHERE construct statement can be nested, we call
gfc_trans_where_2 to do the translation, and pass the initial
- NULL values for both the control mask and the pending control mask. */
+ NULL values for both the control mask and the pending control mask. */
tree
gfc_trans_where (gfc_code * code)
}
-/* EXIT a DO loop. Similair to CYCLE, but now the label is in
+/* EXIT a DO loop. Similar to CYCLE, but now the label is in
TREE_VALUE (backend_decl) of the gfc_code node at the head of the
loop. */
OSDN Git Service
