#include "toplev.h"
#include "real.h"
#include "gfortran.h"
+#include "flags.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "arith.h"
+#include "dependency.h"
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;
}
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, bool,
+ forall_info *, stmtblock_t *);
/* Translate a F95 label number to a LABEL_EXPR. */
tree
gfc_trans_goto (gfc_code * code)
{
+ locus loc = code->loc;
tree assigned_goto;
tree target;
tree tmp;
- tree assign_error;
- tree range_error;
gfc_se se;
-
if (code->label != NULL)
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
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);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1));
- gfc_trans_runtime_check (tmp, assign_error, &se.pre);
+ gfc_trans_runtime_check (tmp, "Assigned label is not a target label",
+ &se.pre, &loc);
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
}
/* Check the label list. */
- range_error = gfc_build_cstring_const ("Assigned label is not in the list");
-
do
{
target = gfc_get_label_decl (code->label);
code = code->block;
}
while (code != NULL);
- gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
+ gfc_trans_runtime_check (boolean_true_node,
+ "Assigned label is not in the list", &se.pre, &loc);
+
return gfc_finish_block (&se.pre);
}
}
+/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
+ elemental subroutines. Make temporaries for output arguments if any such
+ dependencies are found. Output arguments are chosen because internal_unpack
+ can be used, as is, to copy the result back to the variable. */
+static void
+gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
+ gfc_symbol * sym, gfc_actual_arglist * arg)
+{
+ gfc_actual_arglist *arg0;
+ gfc_expr *e;
+ gfc_formal_arglist *formal;
+ gfc_loopinfo tmp_loop;
+ gfc_se parmse;
+ gfc_ss *ss;
+ gfc_ss_info *info;
+ gfc_symbol *fsym;
+ int n;
+ stmtblock_t block;
+ tree data;
+ tree offset;
+ tree size;
+ tree tmp;
+
+ if (loopse->ss == NULL)
+ return;
+
+ ss = loopse->ss;
+ arg0 = arg;
+ formal = sym->formal;
+
+ /* Loop over all the arguments testing for dependencies. */
+ for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
+ {
+ e = arg->expr;
+ if (e == NULL)
+ continue;
+
+ /* Obtain the info structure for the current argument. */
+ info = NULL;
+ for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
+ {
+ if (ss->expr != e)
+ continue;
+ info = &ss->data.info;
+ break;
+ }
+
+ /* If there is a dependency, create a temporary and use it
+ instead of the variable. */
+ fsym = formal ? formal->sym : NULL;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->rank && fsym
+ && fsym->attr.intent == INTENT_OUT
+ && gfc_check_fncall_dependency (e, INTENT_OUT, sym, arg0))
+ {
+ /* Make a local loopinfo for the temporary creation, so that
+ none of the other ss->info's have to be renormalized. */
+ gfc_init_loopinfo (&tmp_loop);
+ for (n = 0; n < info->dimen; n++)
+ {
+ tmp_loop.to[n] = loopse->loop->to[n];
+ tmp_loop.from[n] = loopse->loop->from[n];
+ tmp_loop.order[n] = loopse->loop->order[n];
+ }
+
+ /* Generate the temporary. Merge the block so that the
+ declarations are put at the right binding level. */
+ size = gfc_create_var (gfc_array_index_type, NULL);
+ data = gfc_create_var (pvoid_type_node, NULL);
+ gfc_start_block (&block);
+ tmp = gfc_typenode_for_spec (&e->ts);
+ tmp = gfc_trans_create_temp_array (&se->pre, &se->post,
+ &tmp_loop, info, tmp,
+ false, true, false, false);
+ gfc_add_modify_expr (&se->pre, size, tmp);
+ tmp = fold_convert (pvoid_type_node, info->data);
+ gfc_add_modify_expr (&se->pre, data, tmp);
+ gfc_merge_block_scope (&block);
+
+ /* Obtain the argument descriptor for unpacking. */
+ gfc_init_se (&parmse, NULL);
+ parmse.want_pointer = 1;
+ gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
+ gfc_add_block_to_block (&se->pre, &parmse.pre);
+
+ /* Calculate the offset for the temporary. */
+ offset = gfc_index_zero_node;
+ for (n = 0; n < info->dimen; n++)
+ {
+ tmp = gfc_conv_descriptor_stride (info->descriptor,
+ gfc_rank_cst[n]);
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ loopse->loop->from[n], tmp);
+ offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ offset, tmp);
+ }
+ info->offset = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify_expr (&se->pre, info->offset, offset);
+
+ /* Copy the result back using unpack. */
+ tmp = gfc_chainon_list (NULL_TREE, parmse.expr);
+ tmp = gfc_chainon_list (tmp, data);
+ tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ gfc_add_block_to_block (&se->post, &parmse.post);
+ }
+ }
+}
+
+
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
tree
-gfc_trans_call (gfc_code * code)
+gfc_trans_call (gfc_code * code, bool dependency_check)
{
gfc_se se;
gfc_ss * ss;
/* Translate the call. */
has_alternate_specifier
- = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
+ = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
+ NULL_TREE);
/* A subroutine without side-effect, by definition, does nothing! */
TREE_SIDE_EFFECTS (se.expr) = 1;
gfc_conv_loop_setup (&loop);
gfc_mark_ss_chain_used (ss, 1);
+ /* Convert the arguments, checking for dependencies. */
+ gfc_copy_loopinfo_to_se (&loopse, &loop);
+ loopse.ss = ss;
+
+ /* For operator assignment, we need to do dependency checking.
+ We also check the intent of the parameters. */
+ if (dependency_check)
+ {
+ gfc_symbol *sym;
+ sym = code->resolved_sym;
+ gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT);
+ gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN);
+ gfc_conv_elemental_dependencies (&se, &loopse, sym,
+ code->ext.actual);
+ }
+
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
gfc_init_block (&block);
- gfc_copy_loopinfo_to_se (&loopse, &loop);
- loopse.ss = ss;
/* Add the subroutine call to the block. */
- gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
+ gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
+ NULL_TREE);
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
gfc_add_block_to_block (&block, &loopse.pre);
gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se.pre, &loop.pre);
gfc_add_block_to_block (&se.pre, &loop.post);
+ gfc_add_block_to_block (&se.pre, &se.post);
gfc_cleanup_loop (&loop);
}
in a subroutine and current_fake_result_decl has already
been generated. */
- result = gfc_get_fake_result_decl (NULL);
+ result = gfc_get_fake_result_decl (NULL, 0);
if (!result)
{
gfc_warning ("An alternate return at %L without a * dummy argument",
}
-/* Translage an arithmetic IF expression.
+/* Translate an arithmetic IF expression.
IF (cond) label1, label2, label3 translates to
/* Pre-evaluate COND. */
gfc_conv_expr_val (&se, code->expr);
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
/* Build something to compare with. */
zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
to:
[evaluate loop bounds and step]
- count = to + step - from;
+ count = (to + step - from) / step;
dovar = from;
for (;;)
{
}
gfc_add_modify_expr (&block, count, tmp);
- count_one = convert (TREE_TYPE (count), integer_one_node);
+ count_one = build_int_cst (TREE_TYPE (count), 1);
/* Initialize the DO variable: dovar = from. */
gfc_add_modify_expr (&block, dovar, from);
internal representation of CASE(N).
In the first and second case, we need to set a value for
- high. In the thirth case, we don't because the GCC middle
+ high. In the third case, we don't because the GCC middle
end represents a single case value by just letting high be
a NULL_TREE. We can't do that because we need to be able
to represent unbounded cases. */
gfc_trans_character_select (gfc_code *code)
{
tree init, node, end_label, tmp, type, args, *labels;
+ tree case_label;
stmtblock_t block, body;
gfc_case *cp, *d;
gfc_code *c;
gfc_add_block_to_block (&block, &se.pre);
tmp = build_function_call_expr (gfor_fndecl_select_string, args);
- tmp = build1 (GOTO_EXPR, void_type_node, tmp);
+ case_label = gfc_create_var (TREE_TYPE (tmp), "case_label");
+ gfc_add_modify_expr (&block, case_label, tmp);
+
+ gfc_add_block_to_block (&block, &se.post);
+
+ tmp = build1 (GOTO_EXPR, void_type_node, case_label);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&body);
static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
- tree count1, tree wheremask)
+ tree count1, tree wheremask, bool invert)
{
gfc_ss *lss;
gfc_se lse, rse;
stmtblock_t block, body;
gfc_loopinfo loop1;
- tree tmp, tmp2;
+ tree tmp;
tree wheremaskexpr;
/* Walk the lhs. */
gfc_conv_expr (&lse, expr);
/* Use the scalar assignment. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+ rse.string_length = lse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
- /* Form the mask expression according to the mask tree list. */
- if (wheremask)
- {
- wheremaskexpr = gfc_build_array_ref (wheremask, count3);
- tmp2 = TREE_CHAIN (wheremask);
- while (tmp2)
- {
- tmp1 = gfc_build_array_ref (tmp2, count3);
- wheremaskexpr = fold_build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
- wheremaskexpr, tmp1);
- tmp2 = TREE_CHAIN (tmp2);
- }
- tmp = fold_build3 (COND_EXPR, void_type_node,
- wheremaskexpr, tmp, build_empty_stmt ());
+ /* Form the mask expression according to the mask tree list. */
+ if (wheremask)
+ {
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3);
+ if (invert)
+ wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
+ TREE_TYPE (wheremaskexpr),
+ wheremaskexpr);
+ tmp = fold_build3 (COND_EXPR, void_type_node,
+ wheremaskexpr, tmp, build_empty_stmt ());
}
gfc_add_expr_to_block (&body, tmp);
}
-/* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
- LSS and RSS are formed in function compute_inner_temp_size(), and should
- not be freed. */
+/* Generate codes to copy rhs to the temporary. TMP1 is the address of
+ temporary, LSS and RSS are formed in function compute_inner_temp_size(),
+ and should not be freed. WHEREMASK is the conditional execution mask
+ whose sense may be inverted by INVERT. */
static tree
generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
tree count1, gfc_ss *lss, gfc_ss *rss,
- tree wheremask)
+ tree wheremask, bool invert)
{
stmtblock_t block, body1;
gfc_loopinfo loop;
gfc_se lse;
gfc_se rse;
- tree tmp, tmp2;
+ tree tmp;
tree wheremaskexpr;
gfc_start_block (&block);
}
/* Use the scalar assignment. */
- tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
+ lse.string_length = rse.string_length;
+ tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
+ expr2->expr_type == EXPR_VARIABLE);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3);
- tmp2 = TREE_CHAIN (wheremask);
- while (tmp2)
- {
- tmp1 = gfc_build_array_ref (tmp2, count3);
- wheremaskexpr = fold_build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
- wheremaskexpr, tmp1);
- tmp2 = TREE_CHAIN (tmp2);
- }
+ if (invert)
+ wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
+ TREE_TYPE (wheremaskexpr),
+ wheremaskexpr);
tmp = fold_build3 (COND_EXPR, void_type_node,
wheremaskexpr, tmp, build_empty_stmt ());
}
gfc_loopinfo loop;
tree size;
int i;
+ int save_flag;
tree tmp;
*lss = gfc_walk_expr (expr1);
loop.array_parameter = 1;
/* Calculate the bounds of the scalarization. */
+ save_flag = flag_bounds_check;
+ flag_bounds_check = 0;
gfc_conv_ss_startstride (&loop);
+ flag_bounds_check = save_flag;
gfc_conv_loop_setup (&loop);
/* Figure out how many elements we need. */
DEALLOCATE (tmp)
*/
static void
-gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
+gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
+ tree wheremask, bool invert,
forall_info * nested_forall_info,
stmtblock_t * block)
{
/* Generate codes to copy rhs to the temporary . */
tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
- wheremask);
+ wheremask, invert);
/* 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, count, count1, wheremask);
+ tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
+ wheremask, invert);
/* Generate body and loops according to the information in
nested_forall_info. */
gfc_saved_var *saved_vars;
iter_info *this_forall, *iter_tmp;
forall_info *info, *forall_tmp;
- temporary_list *temp;
gfc_start_block (&block);
{
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)
- gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
+ gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, false,
nested_forall_info, &block);
else
{
/* Use the normal assignment copying routines. */
- assign = gfc_trans_assignment (c->expr, c->expr2);
+ assign = gfc_trans_assignment (c->expr, c->expr2, false);
/* Generate body and loops. */
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
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 = build_function_call_expr (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, false, 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);
/* Explicit subroutine calls are prevented by the frontend but interface
assignments can legitimately produce them. */
- case EXEC_CALL:
- assign = gfc_trans_call (c);
+ case EXEC_ASSIGN_CALL:
+ assign = gfc_trans_call (c, true);
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
gfc_add_expr_to_block (&block, tmp);
break;
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, whose sense may or may
+ not be inverted as specified by the INVERT argument.
+ 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, bool invert, 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");
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);
+ /* Variable to evaluate 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);
+ if (invert)
+ tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
+ gfc_add_modify_expr (&body1, mtmp, tmp);
+ }
- /* Fill temporary NTMP. */
- tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
- gfc_add_modify_expr (&body1, tmpexpr, tmp1);
+ 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 (lss == gfc_ss_terminator)
+ 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);
}
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;
}
/* Translate an assignment statement in a WHERE statement or construct
statement. The MASK expression is used to control which elements
- of EXPR1 shall be assigned. */
+ of EXPR1 shall be assigned. The sense of MASK is specified by
+ INVERT. */
static tree
-gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
+gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
+ tree mask, bool invert,
tree count1, tree count2)
{
gfc_se lse;
tree tmp;
stmtblock_t block;
stmtblock_t body;
- tree index, maskexpr, tmp1;
+ tree index, maskexpr;
#if 0
/* TODO: handle this special case.
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;
+ maskexpr = gfc_build_array_ref (mask, index);
+ if (invert)
+ maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
- 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 = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
+ loop.temp_ss != NULL, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
/* 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);
+ if (invert)
+ maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
+ maskexpr);
- 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 = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
/* 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, bool invert,
+ 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;
+ bool need_cmask;
+ bool need_pmask;
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;
+
+ /* As the mask array can be very big, prefer compact boolean types. */
+ mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
+
+ /* Determine which temporary masks are needed. */
+ if (!cblock->block)
+ {
+ /* One clause: No ELSEWHEREs. */
+ need_cmask = (cblock->next != 0);
+ need_pmask = false;
+ }
+ else if (cblock->block->block)
+ {
+ /* Three or more clauses: Conditional ELSEWHEREs. */
+ need_cmask = true;
+ need_pmask = true;
+ }
+ else if (cblock->next)
+ {
+ /* Two clauses, the first non-empty. */
+ need_cmask = true;
+ need_pmask = (mask != NULL_TREE
+ && cblock->block->next != 0);
+ }
+ else if (!cblock->block->next)
+ {
+ /* Two clauses, both empty. */
+ need_cmask = false;
+ need_pmask = false;
+ }
+ /* Two clauses, the first empty, the second non-empty. */
+ else if (mask)
+ {
+ need_cmask = (cblock->block->expr != 0);
+ need_pmask = true;
+ }
+ else
+ {
+ need_cmask = true;
+ need_pmask = false;
+ }
+
+ if (need_cmask || need_pmask)
+ {
+ /* 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);
+
+ /* Allocate temporary for WHERE mask if needed. */
+ if (need_cmask)
+ cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+ &pcmask);
+
+ /* Allocate temporary for !mask if needed. */
+ if (need_pmask)
+ pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
+ &ppmask);
+ }
+
while (cblock)
{
+ /* Each time around this loop, the where clause is conditional
+ on the value of mask and invert, which are updated at the
+ bottom of the loop. */
+
/* 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). */
+ if (mask)
+ gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
+ mask, invert,
+ cblock->next ? cmask : NULL_TREE,
+ cblock->block ? pmask : NULL_TREE,
+ mask_type, block);
+ else
+ gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
+ NULL_TREE, false,
+ (cblock->next || cblock->block)
+ ? cmask : NULL_TREE,
+ NULL_TREE, mask_type, block);
- mask = pmask;
- tmp2 = chainon (tmp2, tmp);
- pmask = chainon (mask, tmp1);
- mask = tmp2;
- }
+ invert = false;
}
- /* 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;
+
+ /* The body of this where clause are controlled by cmask with
+ sense specified by invert. */
/* Get the assignment statement of a WHERE statement, or the first
statement in where-body-construct of a WHERE construct. */
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, invert,
nested_forall_info, block);
else
{
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, invert,
+ count1, count2);
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
tmp, 1, 1);
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, invert,
+ count1, count2);
gfc_add_expr_to_block (block, tmp);
}
/* 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;
+ gfc_trans_where_2 (cnext, cmask, invert,
+ nested_forall_info, block);
+ break;
default:
gcc_unreachable ();
}
/* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
cblock = cblock->block;
+ if (mask == NULL_TREE)
+ {
+ /* If we're the initial WHERE, we can simply invert the sense
+ of the current mask to obtain the "mask" for the remaining
+ ELSEWHEREs. */
+ invert = true;
+ mask = cmask;
+ }
+ else
+ {
+ /* Otherwise, for nested WHERE's we need to use the pending mask. */
+ invert = false;
+ 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, false, false);
+ estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
+ : 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
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 = build_function_call_expr (gfor_fndecl_internal_free, args);
- gfc_add_expr_to_block (&block, tmp);
+ gfc_trans_where_2 (code, NULL, false, NULL, &block);
- p = temp;
- temp = temp->next;
- gfc_free (p);
- }
return gfc_finish_block (&block);
}
gfc_se se;
tree tmp;
tree parm;
- gfc_ref *ref;
tree stat;
tree pstat;
tree error_label;
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- ref = expr->ref;
-
- /* Find the last reference in the chain. */
- while (ref && ref->next != NULL)
- {
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
- ref = ref->next;
- }
-
- if (ref != NULL && ref->type == REF_ARRAY)
- {
- /* An array. */
- gfc_array_allocate (&se, ref, pstat);
- }
- else
+ if (!gfc_array_allocate (&se, expr, pstat))
{
/* A scalar or derived type. */
tree val;
gfc_add_modify_expr (&se.pre, val, tmp);
tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+
+ if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
+ tmp = se.string_length;
+
parm = gfc_chainon_list (NULL_TREE, val);
parm = gfc_chainon_list (parm, tmp);
parm = gfc_chainon_list (parm, pstat);
parm, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se.pre, tmp);
}
+
+ if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
+ {
+ tmp = build_fold_indirect_ref (se.expr);
+ tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
}
tmp = gfc_finish_block (&se.pre);
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
+ if (expr->ts.type == BT_DERIVED
+ && expr->ts.derived->attr.alloc_comp)
+ {
+ gfc_ref *ref;
+ gfc_ref *last = NULL;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ /* Do not deallocate the components of a derived type
+ ultimate pointer component. */
+ if (!(last && last->u.c.component->pointer)
+ && !(!last && expr->symtree->n.sym->attr.pointer))
+ {
+ tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
+ expr->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+ }
+
if (expr->rank)
tmp = gfc_array_deallocate (se.expr, pstat);
else
OSDN Git Service
