File gcc41-fortran-where-opt.patch of Package gcc41
Index: gcc-4.1.2-20070115/gcc/fortran/Make-lang.in
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/Make-lang.in 2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/Make-lang.in 2009-11-20 13:42:12.000000000 +0100
@@ -287,7 +287,7 @@ fortran/trans-types.o: $(GFORTRAN_TRANS_
real.h toplev.h $(TARGET_H)
fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
-fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS)
+fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h \
fortran/ioparm.def
fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS)
Index: gcc-4.1.2-20070115/gcc/fortran/dependency.c
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/dependency.c 2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/dependency.c 2009-11-20 13:42:12.000000000 +0100
@@ -259,10 +259,10 @@ gfc_check_argument_var_dependency (gfc_e
{
case EXPR_VARIABLE:
return (gfc_ref_needs_temporary_p (expr->ref)
- || gfc_check_dependency (var, expr, NULL, 0));
+ || gfc_check_dependency (var, expr, 1));
case EXPR_ARRAY:
- return gfc_check_dependency (var, expr, NULL, 0);
+ return gfc_check_dependency (var, expr, 1);
case EXPR_FUNCTION:
if (intent != INTENT_IN && expr->inline_noncopying_intrinsic)
@@ -384,15 +384,14 @@ return 0;
/* Return true if the statement body redefines the condition. Returns
true if expr2 depends on expr1. expr1 should be a single term
- suitable for the lhs of an assignment. The symbols listed in VARS
- must be considered to have all possible values. All other scalar
- variables may be considered constant. Used for forall and where
+ suitable for the lhs of an assignment. The IDENTICAL flag indicates
+ whether array references to the same symbol with identical range
+ references count as a dependency or not. Used for forall and where
statements. Also used with functions returning arrays without a
temporary. */
int
-gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars,
- int nvars)
+gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, bool identical)
{
gfc_ref *ref;
int n;
@@ -412,11 +411,11 @@ gfc_check_dependency (gfc_expr * expr1,
switch (expr2->expr_type)
{
case EXPR_OP:
- n = gfc_check_dependency (expr1, expr2->value.op.op1, vars, nvars);
+ n = gfc_check_dependency (expr1, expr2->value.op.op1, identical);
if (n)
return n;
if (expr2->value.op.op2)
- return gfc_check_dependency (expr1, expr2->value.op.op2, vars, nvars);
+ return gfc_check_dependency (expr1, expr2->value.op.op2, identical);
return 0;
case EXPR_VARIABLE:
@@ -436,15 +435,25 @@ gfc_check_dependency (gfc_expr * expr1,
if (expr1->symtree->n.sym != expr2->symtree->n.sym)
return 0;
- for (ref = expr2->ref; ref; ref = ref->next)
- {
- /* Identical ranges return 0, overlapping ranges return 1. */
- if (ref->type == REF_ARRAY)
- return 1;
- }
+ if (identical)
+ return 1;
+
+ /* Identical ranges return 0, overlapping ranges return 1. */
+
+ /* Return zero if we refer to the same full arrays. */
+ if (expr1->ref->type == REF_ARRAY
+ && expr2->ref->type == REF_ARRAY
+ && expr1->ref->u.ar.type == AR_FULL
+ && expr2->ref->u.ar.type == AR_FULL
+ && !expr1->ref->next
+ && !expr2->ref->next)
+ return 0;
+
return 1;
case EXPR_FUNCTION:
+ if (expr2->inline_noncopying_intrinsic)
+ identical = 1;
/* Remember possible differences between elemental and
transformational functions. All functions inside a FORALL
will be pure. */
@@ -453,7 +462,7 @@ gfc_check_dependency (gfc_expr * expr1,
{
if (!actual->expr)
continue;
- n = gfc_check_dependency (expr1, actual->expr, vars, nvars);
+ n = gfc_check_dependency (expr1, actual->expr, identical);
if (n)
return n;
}
Index: gcc-4.1.2-20070115/gcc/fortran/dependency.h
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/dependency.h 2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/dependency.h 2009-11-20 13:42:12.000000000 +0100
@@ -25,7 +25,7 @@ bool gfc_ref_needs_temporary_p (gfc_ref
gfc_expr *gfc_get_noncopying_intrinsic_argument (gfc_expr *);
int gfc_check_fncall_dependency (gfc_expr *, sym_intent, gfc_symbol *,
gfc_actual_arglist *);
-int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
+int gfc_check_dependency (gfc_expr *, gfc_expr *, bool);
int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int);
int gfc_expr_is_one (gfc_expr *, int);
Index: gcc-4.1.2-20070115/gcc/fortran/trans-array.h
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/trans-array.h 2009-11-20 13:42:11.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/trans-array.h 2009-11-20 13:42:12.000000000 +0100
@@ -116,9 +116,6 @@ tree gfc_conv_descriptor_stride (tree, t
tree gfc_conv_descriptor_lbound (tree, tree);
tree gfc_conv_descriptor_ubound (tree, tree);
-/* Dependency checking for WHERE and FORALL. */
-int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int);
-
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
Index: gcc-4.1.2-20070115/gcc/fortran/trans-stmt.c
===================================================================
--- gcc-4.1.2-20070115.orig/gcc/fortran/trans-stmt.c 2006-11-07 18:33:22.000000000 +0100
+++ gcc-4.1.2-20070115/gcc/fortran/trans-stmt.c 2009-11-20 13:42:12.000000000 +0100
@@ -37,6 +37,7 @@ Software Foundation, 51 Franklin Street,
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"
+#include "dependency.h"
typedef struct iter_info
{
@@ -48,13 +49,6 @@ typedef struct iter_info
}
iter_info;
-typedef struct temporary_list
-{
- tree temporary;
- struct temporary_list *next;
-}
-temporary_list;
-
typedef struct forall_info
{
iter_info *this_loop;
@@ -68,8 +62,7 @@ typedef struct forall_info
}
forall_info;
-static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
- stmtblock_t *, temporary_list **temp);
+static void gfc_trans_where_2 (gfc_code *, tree, forall_info *, stmtblock_t *);
/* Translate a F95 label number to a LABEL_EXPR. */
@@ -258,7 +251,7 @@ gfc_conv_elemental_dependencies (gfc_se
&& fsym->attr.intent == INTENT_OUT
&& arg->next->expr
&& arg->next->expr->expr_type == EXPR_VARIABLE
- && gfc_check_dependency (e, arg->next->expr, NULL, 0))
+ && gfc_check_dependency (e, arg->next->expr, 1))
{
/* Make a local loopinfo for the temporary creation, so that
none of the other ss->info's have to be renormalized. */
@@ -2446,7 +2439,6 @@ gfc_trans_forall_1 (gfc_code * code, for
gfc_saved_var *saved_vars;
iter_info *this_forall, *iter_tmp;
forall_info *info, *forall_tmp;
- temporary_list *temp;
gfc_start_block (&block);
@@ -2633,7 +2625,7 @@ gfc_trans_forall_1 (gfc_code * code, for
{
case EXEC_ASSIGN:
/* A scalar or array assignment. */
- need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
+ need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
if (need_temp)
@@ -2652,31 +2644,13 @@ gfc_trans_forall_1 (gfc_code * code, for
break;
case EXEC_WHERE:
-
/* Translate WHERE or WHERE construct nested in FORALL. */
- temp = NULL;
- gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
-
- while (temp)
- {
- tree args;
- temporary_list *p;
-
- /* Free the temporary. */
- args = gfc_chainon_list (NULL_TREE, temp->temporary);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
- gfc_add_expr_to_block (&block, tmp);
-
- p = temp;
- temp = temp->next;
- gfc_free (p);
- }
-
- break;
+ gfc_trans_where_2 (c, NULL, nested_forall_info, &block);
+ break;
/* Pointer assignment inside FORALL. */
case EXEC_POINTER_ASSIGN:
- need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
+ need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
if (need_temp)
gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
nested_forall_info, &block);
@@ -2751,62 +2725,27 @@ tree gfc_trans_forall (gfc_code * code)
needed by the WHERE mask expression multiplied by the iterator number of
the nested forall.
ME is the WHERE mask expression.
- MASK is the temporary which value is mask's value.
- NMASK is another temporary which value is !mask.
- TEMP records the temporary's address allocated in this function in order to
- free them outside this function.
- MASK, NMASK and TEMP are all OUT arguments. */
+ MASK is the current execution mask upon input.
+ CMASK is the updated execution mask on output, or NULL if not required.
+ PMASK is the pending execution mask on output, or NULL if not required.
+ BLOCK is the block in which to place the condition evaluation loops. */
-static tree
+static void
gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
- tree * mask, tree * nmask, temporary_list ** temp,
- stmtblock_t * block)
+ tree mask, tree cmask, tree pmask,
+ tree mask_type, stmtblock_t * block)
{
tree tmp, tmp1;
gfc_ss *lss, *rss;
gfc_loopinfo loop;
- tree ptemp1, ntmp, ptemp2;
- tree inner_size, size;
- stmtblock_t body, body1, inner_size_body;
+ stmtblock_t body, body1;
+ tree count, cond, mtmp;
gfc_se lse, rse;
- tree count;
- tree tmpexpr;
gfc_init_loopinfo (&loop);
- /* Calculate the size of temporary needed by the mask-expr. */
- 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_1 (boolean_type_node, size, block,
- &ptemp1);
- /* Record the temporary address in order to free it later. */
- if (ptemp1)
- {
- temporary_list *tempo;
- tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
- tempo->temporary = ptemp1;
- tempo->next = *temp;
- *temp = tempo;
- }
-
- /* Allocate temporary for !mask. */
- ntmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
- &ptemp2);
- /* Record the temporary in order to free it later. */
- if (ptemp2)
- {
- temporary_list *tempo;
- tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
- tempo->temporary = ptemp2;
- tempo->next = *temp;
- *temp = tempo;
- }
+ lss = gfc_walk_expr (me);
+ rss = gfc_walk_expr (me);
/* Variable to index the temporary. */
count = gfc_create_var (gfc_array_index_type, "count");
@@ -2843,19 +2782,46 @@ gfc_evaluate_where_mask (gfc_expr * me,
rse.ss = rss;
gfc_conv_expr (&rse, me);
}
- /* Form the expression of the temporary. */
- lse.expr = gfc_build_array_ref (tmp, count);
- tmpexpr = gfc_build_array_ref (ntmp, count);
-
- /* Use the scalar assignment to fill temporary TMP. */
- tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
- gfc_add_expr_to_block (&body1, tmp1);
-
- /* Fill temporary NTMP. */
- tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
- gfc_add_modify_expr (&body1, tmpexpr, tmp1);
- if (lss == gfc_ss_terminator)
+ /* Variable to evalate mask condition. */
+ cond = gfc_create_var (mask_type, "cond");
+ if (mask && (cmask || pmask))
+ mtmp = gfc_create_var (mask_type, "mask");
+ else mtmp = NULL_TREE;
+
+ gfc_add_block_to_block (&body1, &lse.pre);
+ gfc_add_block_to_block (&body1, &rse.pre);
+
+ gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr));
+
+ if (mask && (cmask || pmask))
+ {
+ tmp = gfc_build_array_ref (mask, count);
+ gfc_add_modify_expr (&body1, mtmp, tmp);
+ }
+
+ if (cmask)
+ {
+ tmp1 = gfc_build_array_ref (cmask, count);
+ tmp = cond;
+ if (mask)
+ tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
+ gfc_add_modify_expr (&body1, tmp1, tmp);
+ }
+
+ if (pmask)
+ {
+ tmp1 = gfc_build_array_ref (pmask, count);
+ tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
+ if (mask)
+ tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
+ gfc_add_modify_expr (&body1, tmp1, tmp);
+ }
+
+ gfc_add_block_to_block (&body1, &lse.post);
+ gfc_add_block_to_block (&body1, &rse.post);
+
+ if (lss == gfc_ss_terminator)
{
gfc_add_block_to_block (&body, &body1);
}
@@ -2883,11 +2849,6 @@ gfc_evaluate_where_mask (gfc_expr * me,
tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
gfc_add_expr_to_block (block, tmp1);
-
- *mask = tmp;
- *nmask = ntmp;
-
- return tmp1;
}
@@ -2909,7 +2870,7 @@ gfc_trans_where_assign (gfc_expr *expr1,
tree tmp;
stmtblock_t block;
stmtblock_t body;
- tree index, maskexpr, tmp1;
+ tree index, maskexpr;
#if 0
/* TODO: handle this special case.
@@ -3004,21 +2965,10 @@ gfc_trans_where_assign (gfc_expr *expr1,
else
gfc_conv_expr (&lse, expr1);
- /* Form the mask expression according to the mask tree list. */
+ /* Form the mask expression according to the mask. */
index = count1;
- tmp = mask;
- if (tmp != NULL)
- maskexpr = gfc_build_array_ref (tmp, index);
- else
- maskexpr = NULL;
-
- tmp = TREE_CHAIN (tmp);
- while (tmp)
- {
- tmp1 = gfc_build_array_ref (tmp, index);
- maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
- tmp = TREE_CHAIN (tmp);
- }
+ maskexpr = gfc_build_array_ref (mask, index);
+
/* Use the scalar assignment as is. */
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
@@ -3067,20 +3017,8 @@ gfc_trans_where_assign (gfc_expr *expr1,
/* Form the mask expression according to the mask tree list. */
index = count2;
- tmp = mask;
- if (tmp != NULL)
- maskexpr = gfc_build_array_ref (tmp, index);
- else
- maskexpr = NULL;
+ maskexpr = gfc_build_array_ref (mask, index);
- tmp = TREE_CHAIN (tmp);
- while (tmp)
- {
- tmp1 = gfc_build_array_ref (tmp, index);
- maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
- maskexpr, tmp1);
- tmp = TREE_CHAIN (tmp);
- }
/* Use the scalar assignment as is. */
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
@@ -3115,65 +3053,93 @@ gfc_trans_where_assign (gfc_expr *expr1,
/* Translate the WHERE construct or statement.
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. */
+ MASK is the control mask. */
static void
-gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
- forall_info * nested_forall_info, stmtblock_t * block,
- temporary_list ** temp)
+gfc_trans_where_2 (gfc_code * code, tree mask,
+ forall_info * nested_forall_info, stmtblock_t * block)
{
+ stmtblock_t inner_size_body;
+ tree inner_size, size;
+ gfc_ss *lss, *rss;
+ tree mask_type;
gfc_expr *expr1;
gfc_expr *expr2;
gfc_code *cblock;
gfc_code *cnext;
- tree tmp, tmp1, tmp2;
+ tree tmp;
tree count1, count2;
- tree mask_copy;
int need_temp;
+ tree pcmask = NULL_TREE;
+ tree ppmask = NULL_TREE;
+ tree cmask = NULL_TREE;
+ tree pmask = NULL_TREE;
/* the WHERE statement or the WHERE construct statement. */
cblock = code->block;
+
+ /* Calculate the size of temporary needed by the mask-expr. */
+ gfc_init_block (&inner_size_body);
+ inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
+ &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);
+
+ /* As the mask array can be very big, prefer compact boolean types. */
+ mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+
+ /* Allocate temporary for WHERE mask. We only need a "cmask" if
+ there are statements to be executed. The following test only
+ checks the first ELSEWHERE to catch the F90 cases. */
+ if (cblock->next
+ || (cblock->block && cblock->block->next && cblock->block->expr)
+ || (cblock->block && cblock->block->block))
+ {
+ cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+ &pcmask);
+ }
+ else
+ {
+ pcmask = NULL_TREE;
+ cmask = NULL_TREE;
+ }
+
+ /* Allocate temporary for !mask. We only need a "pmask" if there
+ is an ELSEWHERE clause containing executable statements. Again
+ we only lookahead a single ELSEWHERE to catch the F90 cases. */
+ if ((cblock->block && cblock->block->next)
+ || (cblock->block && cblock->block->block))
+ {
+ pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+ &ppmask);
+ }
+ else
+ {
+ ppmask = NULL_TREE;
+ pmask = NULL_TREE;
+ }
+
while (cblock)
{
/* Has mask-expr. */
if (cblock->expr)
{
- /* Ensure that the WHERE mask be evaluated only once. */
- tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
- &tmp, &tmp1, temp, block);
-
- /* Set the control mask and the pending control mask. */
- /* It's a where-stmt. */
- if (mask == NULL)
- {
- mask = tmp;
- pmask = tmp1;
- }
- /* It's a nested where-stmt. */
- else if (mask && pmask == NULL)
- {
- tree tmp2;
- /* Use the TREE_CHAIN to list the masks. */
- tmp2 = copy_list (mask);
- pmask = chainon (mask, tmp1);
- mask = chainon (tmp2, tmp);
- }
- /* It's a masked-elsewhere-stmt. */
- else if (mask && cblock->expr)
- {
- tree tmp2;
- tmp2 = copy_list (pmask);
+ /* Ensure that the WHERE mask will be evaluated exactly once.
+ If there are no statements in this WHERE/ELSEWHERE clause,
+ then we don't need to update the control mask (cmask).
+ If this is the last clause of the WHERE construct, then
+ we don't need to update the pending control mask (pmask). */
+ gfc_evaluate_where_mask (cblock->expr, nested_forall_info, mask,
+ cblock->next ? cmask : NULL_TREE,
+ cblock->block ? pmask : NULL_TREE,
+ mask_type, block);
- mask = pmask;
- tmp2 = chainon (tmp2, tmp);
- pmask = chainon (mask, tmp1);
- mask = tmp2;
- }
}
- /* It's a elsewhere-stmt. No mask-expr is present. */
+ /* It's a final elsewhere-stmt. No mask-expr is present. */
else
- mask = pmask;
+ cmask = mask;
/* Get the assignment statement of a WHERE statement, or the first
statement in where-body-construct of a WHERE construct. */
@@ -3188,16 +3154,9 @@ gfc_trans_where_2 (gfc_code * code, tree
expr2 = cnext->expr2;
if (nested_forall_info != NULL)
{
- int nvar;
- gfc_expr **varexpr;
-
- nvar = nested_forall_info->nvar;
- varexpr = (gfc_expr **)
- gfc_getmem (nvar * sizeof (gfc_expr *));
- need_temp = gfc_check_dependency (expr1, expr2, varexpr,
- nvar);
+ need_temp = gfc_check_dependency (expr1, expr2, 0);
if (need_temp)
- gfc_trans_assign_need_temp (expr1, expr2, mask,
+ gfc_trans_assign_need_temp (expr1, expr2, cmask,
nested_forall_info, block);
else
{
@@ -3207,8 +3166,8 @@ gfc_trans_where_2 (gfc_code * code, tree
gfc_add_modify_expr (block, count1, gfc_index_zero_node);
gfc_add_modify_expr (block, count2, gfc_index_zero_node);
- tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
- count2);
+ tmp = gfc_trans_where_assign (expr1, expr2, cmask,
+ count1, count2);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1, 1);
@@ -3223,8 +3182,8 @@ gfc_trans_where_2 (gfc_code * code, tree
gfc_add_modify_expr (block, count1, gfc_index_zero_node);
gfc_add_modify_expr (block, count2, gfc_index_zero_node);
- tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
- count2);
+ tmp = gfc_trans_where_assign (expr1, expr2, cmask,
+ count1, count2);
gfc_add_expr_to_block (block, tmp);
}
@@ -3232,11 +3191,9 @@ gfc_trans_where_2 (gfc_code * code, tree
/* WHERE or WHERE construct is part of a where-body-construct. */
case EXEC_WHERE:
- /* Ensure that MASK is not modified by next gfc_trans_where_2. */
- mask_copy = copy_list (mask);
- gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
- block, temp);
- break;
+ /* Ensure that MASK is not modified by next gfc_trans_where_2. */
+ gfc_trans_where_2 (cnext, cmask, nested_forall_info, block);
+ break;
default:
gcc_unreachable ();
@@ -3247,9 +3204,157 @@ gfc_trans_where_2 (gfc_code * code, tree
}
/* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
cblock = cblock->block;
+ mask = pmask;
}
+
+ /* If we allocated a pending mask array, deallocate it now. */
+ if (ppmask)
+ {
+ tree args = gfc_chainon_list (NULL_TREE, ppmask);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
+ gfc_add_expr_to_block (block, tmp);
+ }
+
+ /* If we allocated a current mask array, deallocate it now. */
+ if (pcmask)
+ {
+ tree args = gfc_chainon_list (NULL_TREE, pcmask);
+ tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
+ gfc_add_expr_to_block (block, tmp);
+ }
}
+/* Translate a simple WHERE construct or statement without dependencies.
+ CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
+ is the mask condition, and EBLOCK if non-NULL is the "else" clause.
+ Currently both CBLOCK and EBLOCK are restricted to single assignments. */
+
+static tree
+gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
+{
+ stmtblock_t block, body;
+ gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
+ tree tmp, cexpr, tstmt, estmt;
+ gfc_ss *css, *tdss, *tsss;
+ gfc_se cse, tdse, tsse, edse, esse;
+ gfc_loopinfo loop;
+ gfc_ss *edss = 0;
+ gfc_ss *esss = 0;
+
+ cond = cblock->expr;
+ tdst = cblock->next->expr;
+ tsrc = cblock->next->expr2;
+ edst = eblock ? eblock->next->expr : NULL;
+ esrc = eblock ? eblock->next->expr2 : NULL;
+
+ gfc_start_block (&block);
+ gfc_init_loopinfo (&loop);
+
+ /* Handle the condition. */
+ gfc_init_se (&cse, NULL);
+ css = gfc_walk_expr (cond);
+ gfc_add_ss_to_loop (&loop, css);
+
+ /* Handle the then-clause. */
+ gfc_init_se (&tdse, NULL);
+ gfc_init_se (&tsse, NULL);
+ tdss = gfc_walk_expr (tdst);
+ tsss = gfc_walk_expr (tsrc);
+ if (tsss == gfc_ss_terminator)
+ {
+ tsss = gfc_get_ss ();
+ tsss->next = gfc_ss_terminator;
+ tsss->type = GFC_SS_SCALAR;
+ tsss->expr = tsrc;
+ }
+ gfc_add_ss_to_loop (&loop, tdss);
+ gfc_add_ss_to_loop (&loop, tsss);
+
+ if (eblock)
+ {
+ /* Handle the else clause. */
+ gfc_init_se (&edse, NULL);
+ gfc_init_se (&esse, NULL);
+ edss = gfc_walk_expr (edst);
+ esss = gfc_walk_expr (esrc);
+ if (esss == gfc_ss_terminator)
+ {
+ esss = gfc_get_ss ();
+ esss->next = gfc_ss_terminator;
+ esss->type = GFC_SS_SCALAR;
+ esss->expr = esrc;
+ }
+ gfc_add_ss_to_loop (&loop, edss);
+ gfc_add_ss_to_loop (&loop, esss);
+ }
+
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop);
+
+ gfc_mark_ss_chain_used (css, 1);
+ gfc_mark_ss_chain_used (tdss, 1);
+ gfc_mark_ss_chain_used (tsss, 1);
+ if (eblock)
+ {
+ gfc_mark_ss_chain_used (edss, 1);
+ gfc_mark_ss_chain_used (esss, 1);
+ }
+
+ gfc_start_scalarized_body (&loop, &body);
+
+ gfc_copy_loopinfo_to_se (&cse, &loop);
+ gfc_copy_loopinfo_to_se (&tdse, &loop);
+ gfc_copy_loopinfo_to_se (&tsse, &loop);
+ cse.ss = css;
+ tdse.ss = tdss;
+ tsse.ss = tsss;
+ if (eblock)
+ {
+ gfc_copy_loopinfo_to_se (&edse, &loop);
+ gfc_copy_loopinfo_to_se (&esse, &loop);
+ edse.ss = edss;
+ esse.ss = esss;
+ }
+
+ gfc_conv_expr (&cse, cond);
+ gfc_add_block_to_block (&body, &cse.pre);
+ cexpr = cse.expr;
+
+ gfc_conv_expr (&tsse, tsrc);
+ if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
+ {
+ gfc_conv_tmp_array_ref (&tdse);
+ gfc_advance_se_ss_chain (&tdse);
+ }
+ else
+ gfc_conv_expr (&tdse, tdst);
+
+ if (eblock)
+ {
+ gfc_conv_expr (&esse, esrc);
+ if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
+ {
+ gfc_conv_tmp_array_ref (&edse);
+ gfc_advance_se_ss_chain (&edse);
+ }
+ else
+ gfc_conv_expr (&edse, edst);
+ }
+
+ tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
+ estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
+ : build_empty_stmt ();
+ tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_add_block_to_block (&body, &cse.post);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ return gfc_finish_block (&block);
+}
/* As the WHERE or WHERE construct statement can be nested, we call
gfc_trans_where_2 to do the translation, and pass the initial
@@ -3259,26 +3364,57 @@ tree
gfc_trans_where (gfc_code * code)
{
stmtblock_t block;
- temporary_list *temp, *p;
- tree args;
- tree tmp;
+ gfc_code *cblock;
+ gfc_code *eblock;
- gfc_start_block (&block);
- temp = NULL;
+ cblock = code->block;
+ if (cblock->next
+ && cblock->next->op == EXEC_ASSIGN
+ && !cblock->next->next)
+ {
+ eblock = cblock->block;
+ if (!eblock)
+ {
+ /* A simple "WHERE (cond) x = y" statement or block is
+ dependence free if cond is not dependent upon writing x,
+ and the source y is unaffected by the destination x. */
+ if (!gfc_check_dependency (cblock->next->expr,
+ cblock->expr, 0)
+ && !gfc_check_dependency (cblock->next->expr,
+ cblock->next->expr2, 0))
+ return gfc_trans_where_3 (cblock, NULL);
+ }
+ else if (!eblock->expr
+ && !eblock->block
+ && eblock->next
+ && eblock->next->op == EXEC_ASSIGN
+ && !eblock->next->next)
+ {
+ /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
+ block is dependence free if cond is not dependent on writes
+ to x1 and x2, y1 is not dependent on writes to x2, and y2
+ is not dependent on writes to x1, and both y's are not
+ dependent upon their own x's. */
+ if (!gfc_check_dependency(cblock->next->expr,
+ cblock->expr, 0)
+ && !gfc_check_dependency(eblock->next->expr,
+ cblock->expr, 0)
+ && !gfc_check_dependency(cblock->next->expr,
+ eblock->next->expr2, 0)
+ && !gfc_check_dependency(eblock->next->expr,
+ cblock->next->expr2, 0)
+ && !gfc_check_dependency(cblock->next->expr,
+ cblock->next->expr2, 0)
+ && !gfc_check_dependency(eblock->next->expr,
+ eblock->next->expr2, 0))
+ return gfc_trans_where_3 (cblock, eblock);
+ }
+ }
- gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
+ gfc_start_block (&block);
- /* Add calls to free temporaries which were dynamically allocated. */
- while (temp)
- {
- args = gfc_chainon_list (NULL_TREE, temp->temporary);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_trans_where_2 (code, NULL, NULL, &block);
- p = temp;
- temp = temp->next;
- gfc_free (p);
- }
return gfc_finish_block (&block);
}
