/* Statement translation -- generate GCC trees from gfc_code.
|
/* Statement translation -- generate GCC trees from gfc_code.
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
2011, 2012
|
2011, 2012
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Paul Brook <paul@nowt.org>
|
Contributed by Paul Brook <paul@nowt.org>
|
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
GCC is free software; you can redistribute it and/or modify it under
|
the terms of the GNU General Public License as published by the Free
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "coretypes.h"
|
#include "coretypes.h"
|
#include "tree.h"
|
#include "tree.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "trans.h"
|
#include "trans.h"
|
#include "trans-stmt.h"
|
#include "trans-stmt.h"
|
#include "trans-types.h"
|
#include "trans-types.h"
|
#include "trans-array.h"
|
#include "trans-array.h"
|
#include "trans-const.h"
|
#include "trans-const.h"
|
#include "arith.h"
|
#include "arith.h"
|
#include "dependency.h"
|
#include "dependency.h"
|
#include "ggc.h"
|
#include "ggc.h"
|
|
|
typedef struct iter_info
|
typedef struct iter_info
|
{
|
{
|
tree var;
|
tree var;
|
tree start;
|
tree start;
|
tree end;
|
tree end;
|
tree step;
|
tree step;
|
struct iter_info *next;
|
struct iter_info *next;
|
}
|
}
|
iter_info;
|
iter_info;
|
|
|
typedef struct forall_info
|
typedef struct forall_info
|
{
|
{
|
iter_info *this_loop;
|
iter_info *this_loop;
|
tree mask;
|
tree mask;
|
tree maskindex;
|
tree maskindex;
|
int nvar;
|
int nvar;
|
tree size;
|
tree size;
|
struct forall_info *prev_nest;
|
struct forall_info *prev_nest;
|
}
|
}
|
forall_info;
|
forall_info;
|
|
|
static void gfc_trans_where_2 (gfc_code *, tree, bool,
|
static void gfc_trans_where_2 (gfc_code *, tree, bool,
|
forall_info *, stmtblock_t *);
|
forall_info *, stmtblock_t *);
|
|
|
/* Translate a F95 label number to a LABEL_EXPR. */
|
/* Translate a F95 label number to a LABEL_EXPR. */
|
|
|
tree
|
tree
|
gfc_trans_label_here (gfc_code * code)
|
gfc_trans_label_here (gfc_code * code)
|
{
|
{
|
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
|
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
|
}
|
}
|
|
|
|
|
/* Given a variable expression which has been ASSIGNed to, find the decl
|
/* Given a variable expression which has been ASSIGNed to, find the decl
|
containing the auxiliary variables. For variables in common blocks this
|
containing the auxiliary variables. For variables in common blocks this
|
is a field_decl. */
|
is a field_decl. */
|
|
|
void
|
void
|
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
|
gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
|
{
|
{
|
gcc_assert (expr->symtree->n.sym->attr.assign == 1);
|
gcc_assert (expr->symtree->n.sym->attr.assign == 1);
|
gfc_conv_expr (se, expr);
|
gfc_conv_expr (se, expr);
|
/* Deals with variable in common block. Get the field declaration. */
|
/* Deals with variable in common block. Get the field declaration. */
|
if (TREE_CODE (se->expr) == COMPONENT_REF)
|
if (TREE_CODE (se->expr) == COMPONENT_REF)
|
se->expr = TREE_OPERAND (se->expr, 1);
|
se->expr = TREE_OPERAND (se->expr, 1);
|
/* Deals with dummy argument. Get the parameter declaration. */
|
/* Deals with dummy argument. Get the parameter declaration. */
|
else if (TREE_CODE (se->expr) == INDIRECT_REF)
|
else if (TREE_CODE (se->expr) == INDIRECT_REF)
|
se->expr = TREE_OPERAND (se->expr, 0);
|
se->expr = TREE_OPERAND (se->expr, 0);
|
}
|
}
|
|
|
/* Translate a label assignment statement. */
|
/* Translate a label assignment statement. */
|
|
|
tree
|
tree
|
gfc_trans_label_assign (gfc_code * code)
|
gfc_trans_label_assign (gfc_code * code)
|
{
|
{
|
tree label_tree;
|
tree label_tree;
|
gfc_se se;
|
gfc_se se;
|
tree len;
|
tree len;
|
tree addr;
|
tree addr;
|
tree len_tree;
|
tree len_tree;
|
int label_len;
|
int label_len;
|
|
|
/* Start a new block. */
|
/* Start a new block. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
gfc_conv_label_variable (&se, code->expr1);
|
gfc_conv_label_variable (&se, code->expr1);
|
|
|
len = GFC_DECL_STRING_LEN (se.expr);
|
len = GFC_DECL_STRING_LEN (se.expr);
|
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
|
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
|
|
|
label_tree = gfc_get_label_decl (code->label1);
|
label_tree = gfc_get_label_decl (code->label1);
|
|
|
if (code->label1->defined == ST_LABEL_TARGET)
|
if (code->label1->defined == ST_LABEL_TARGET)
|
{
|
{
|
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
|
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
|
len_tree = integer_minus_one_node;
|
len_tree = integer_minus_one_node;
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_expr *format = code->label1->format;
|
gfc_expr *format = code->label1->format;
|
|
|
label_len = format->value.character.length;
|
label_len = format->value.character.length;
|
len_tree = build_int_cst (gfc_charlen_type_node, label_len);
|
len_tree = build_int_cst (gfc_charlen_type_node, label_len);
|
label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
|
label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
|
format->value.character.string);
|
format->value.character.string);
|
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
|
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
|
}
|
}
|
|
|
gfc_add_modify (&se.pre, len, len_tree);
|
gfc_add_modify (&se.pre, len, len_tree);
|
gfc_add_modify (&se.pre, addr, label_tree);
|
gfc_add_modify (&se.pre, addr, label_tree);
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
/* Translate a GOTO statement. */
|
/* Translate a GOTO statement. */
|
|
|
tree
|
tree
|
gfc_trans_goto (gfc_code * code)
|
gfc_trans_goto (gfc_code * code)
|
{
|
{
|
locus loc = code->loc;
|
locus loc = code->loc;
|
tree assigned_goto;
|
tree assigned_goto;
|
tree target;
|
tree target;
|
tree tmp;
|
tree tmp;
|
gfc_se se;
|
gfc_se se;
|
|
|
if (code->label1 != NULL)
|
if (code->label1 != NULL)
|
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
|
|
/* ASSIGNED GOTO. */
|
/* ASSIGNED GOTO. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
gfc_conv_label_variable (&se, code->expr1);
|
gfc_conv_label_variable (&se, code->expr1);
|
tmp = GFC_DECL_STRING_LEN (se.expr);
|
tmp = GFC_DECL_STRING_LEN (se.expr);
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
|
build_int_cst (TREE_TYPE (tmp), -1));
|
build_int_cst (TREE_TYPE (tmp), -1));
|
gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
|
gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
|
"Assigned label is not a target label");
|
"Assigned label is not a target label");
|
|
|
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
|
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
|
|
|
/* We're going to ignore a label list. It does not really change the
|
/* We're going to ignore a label list. It does not really change the
|
statement's semantics (because it is just a further restriction on
|
statement's semantics (because it is just a further restriction on
|
what's legal code); before, we were comparing label addresses here, but
|
what's legal code); before, we were comparing label addresses here, but
|
that's a very fragile business and may break with optimization. So
|
that's a very fragile business and may break with optimization. So
|
just ignore it. */
|
just ignore it. */
|
|
|
target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
|
target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
|
assigned_goto);
|
assigned_goto);
|
gfc_add_expr_to_block (&se.pre, target);
|
gfc_add_expr_to_block (&se.pre, target);
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
/* Translate an ENTRY statement. Just adds a label for this entry point. */
|
/* Translate an ENTRY statement. Just adds a label for this entry point. */
|
tree
|
tree
|
gfc_trans_entry (gfc_code * code)
|
gfc_trans_entry (gfc_code * code)
|
{
|
{
|
return build1_v (LABEL_EXPR, code->ext.entry->label);
|
return build1_v (LABEL_EXPR, code->ext.entry->label);
|
}
|
}
|
|
|
|
|
/* Replace a gfc_ss structure by another both in the gfc_se struct
|
/* Replace a gfc_ss structure by another both in the gfc_se struct
|
and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
|
and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
|
to replace a variable ss by the corresponding temporary. */
|
to replace a variable ss by the corresponding temporary. */
|
|
|
static void
|
static void
|
replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
|
replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
|
{
|
{
|
gfc_ss **sess, **loopss;
|
gfc_ss **sess, **loopss;
|
|
|
/* The old_ss is a ss for a single variable. */
|
/* The old_ss is a ss for a single variable. */
|
gcc_assert (old_ss->info->type == GFC_SS_SECTION);
|
gcc_assert (old_ss->info->type == GFC_SS_SECTION);
|
|
|
for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
|
for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
|
if (*sess == old_ss)
|
if (*sess == old_ss)
|
break;
|
break;
|
gcc_assert (*sess != gfc_ss_terminator);
|
gcc_assert (*sess != gfc_ss_terminator);
|
|
|
*sess = new_ss;
|
*sess = new_ss;
|
new_ss->next = old_ss->next;
|
new_ss->next = old_ss->next;
|
|
|
|
|
for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
|
for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
|
loopss = &((*loopss)->loop_chain))
|
loopss = &((*loopss)->loop_chain))
|
if (*loopss == old_ss)
|
if (*loopss == old_ss)
|
break;
|
break;
|
gcc_assert (*loopss != gfc_ss_terminator);
|
gcc_assert (*loopss != gfc_ss_terminator);
|
|
|
*loopss = new_ss;
|
*loopss = new_ss;
|
new_ss->loop_chain = old_ss->loop_chain;
|
new_ss->loop_chain = old_ss->loop_chain;
|
new_ss->loop = old_ss->loop;
|
new_ss->loop = old_ss->loop;
|
|
|
gfc_free_ss (old_ss);
|
gfc_free_ss (old_ss);
|
}
|
}
|
|
|
|
|
/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
|
/* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
|
elemental subroutines. Make temporaries for output arguments if any such
|
elemental subroutines. Make temporaries for output arguments if any such
|
dependencies are found. Output arguments are chosen because internal_unpack
|
dependencies are found. Output arguments are chosen because internal_unpack
|
can be used, as is, to copy the result back to the variable. */
|
can be used, as is, to copy the result back to the variable. */
|
static void
|
static void
|
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
|
gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
|
gfc_symbol * sym, gfc_actual_arglist * arg,
|
gfc_symbol * sym, gfc_actual_arglist * arg,
|
gfc_dep_check check_variable)
|
gfc_dep_check check_variable)
|
{
|
{
|
gfc_actual_arglist *arg0;
|
gfc_actual_arglist *arg0;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_formal_arglist *formal;
|
gfc_formal_arglist *formal;
|
gfc_se parmse;
|
gfc_se parmse;
|
gfc_ss *ss;
|
gfc_ss *ss;
|
gfc_symbol *fsym;
|
gfc_symbol *fsym;
|
tree data;
|
tree data;
|
tree size;
|
tree size;
|
tree tmp;
|
tree tmp;
|
|
|
if (loopse->ss == NULL)
|
if (loopse->ss == NULL)
|
return;
|
return;
|
|
|
ss = loopse->ss;
|
ss = loopse->ss;
|
arg0 = arg;
|
arg0 = arg;
|
formal = sym->formal;
|
formal = sym->formal;
|
|
|
/* Loop over all the arguments testing for dependencies. */
|
/* Loop over all the arguments testing for dependencies. */
|
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
|
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
|
{
|
{
|
e = arg->expr;
|
e = arg->expr;
|
if (e == NULL)
|
if (e == NULL)
|
continue;
|
continue;
|
|
|
/* Obtain the info structure for the current argument. */
|
/* Obtain the info structure for the current argument. */
|
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
|
for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
|
if (ss->info->expr == e)
|
if (ss->info->expr == e)
|
break;
|
break;
|
|
|
/* If there is a dependency, create a temporary and use it
|
/* If there is a dependency, create a temporary and use it
|
instead of the variable. */
|
instead of the variable. */
|
fsym = formal ? formal->sym : NULL;
|
fsym = formal ? formal->sym : NULL;
|
if (e->expr_type == EXPR_VARIABLE
|
if (e->expr_type == EXPR_VARIABLE
|
&& e->rank && fsym
|
&& e->rank && fsym
|
&& fsym->attr.intent != INTENT_IN
|
&& fsym->attr.intent != INTENT_IN
|
&& gfc_check_fncall_dependency (e, fsym->attr.intent,
|
&& gfc_check_fncall_dependency (e, fsym->attr.intent,
|
sym, arg0, check_variable))
|
sym, arg0, check_variable))
|
{
|
{
|
tree initial, temptype;
|
tree initial, temptype;
|
stmtblock_t temp_post;
|
stmtblock_t temp_post;
|
gfc_ss *tmp_ss;
|
gfc_ss *tmp_ss;
|
|
|
tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
|
tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
|
GFC_SS_SECTION);
|
GFC_SS_SECTION);
|
gfc_mark_ss_chain_used (tmp_ss, 1);
|
gfc_mark_ss_chain_used (tmp_ss, 1);
|
tmp_ss->info->expr = ss->info->expr;
|
tmp_ss->info->expr = ss->info->expr;
|
replace_ss (loopse, ss, tmp_ss);
|
replace_ss (loopse, ss, tmp_ss);
|
|
|
/* Obtain the argument descriptor for unpacking. */
|
/* Obtain the argument descriptor for unpacking. */
|
gfc_init_se (&parmse, NULL);
|
gfc_init_se (&parmse, NULL);
|
parmse.want_pointer = 1;
|
parmse.want_pointer = 1;
|
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
|
gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
gfc_add_block_to_block (&se->pre, &parmse.pre);
|
|
|
/* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
|
/* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
|
initialize the array temporary with a copy of the values. */
|
initialize the array temporary with a copy of the values. */
|
if (fsym->attr.intent == INTENT_INOUT
|
if (fsym->attr.intent == INTENT_INOUT
|
|| (fsym->ts.type ==BT_DERIVED
|
|| (fsym->ts.type ==BT_DERIVED
|
&& fsym->attr.intent == INTENT_OUT))
|
&& fsym->attr.intent == INTENT_OUT))
|
initial = parmse.expr;
|
initial = parmse.expr;
|
/* For class expressions, we always initialize with the copy of
|
/* For class expressions, we always initialize with the copy of
|
the values. */
|
the values. */
|
else if (e->ts.type == BT_CLASS)
|
else if (e->ts.type == BT_CLASS)
|
initial = parmse.expr;
|
initial = parmse.expr;
|
else
|
else
|
initial = NULL_TREE;
|
initial = NULL_TREE;
|
|
|
if (e->ts.type != BT_CLASS)
|
if (e->ts.type != BT_CLASS)
|
{
|
{
|
/* Find the type of the temporary to create; we don't use the type
|
/* Find the type of the temporary to create; we don't use the type
|
of e itself as this breaks for subcomponent-references in e
|
of e itself as this breaks for subcomponent-references in e
|
(where the type of e is that of the final reference, but
|
(where the type of e is that of the final reference, but
|
parmse.expr's type corresponds to the full derived-type). */
|
parmse.expr's type corresponds to the full derived-type). */
|
/* TODO: Fix this somehow so we don't need a temporary of the whole
|
/* TODO: Fix this somehow so we don't need a temporary of the whole
|
array but instead only the components referenced. */
|
array but instead only the components referenced. */
|
temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
|
temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
|
gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
|
gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
|
temptype = TREE_TYPE (temptype);
|
temptype = TREE_TYPE (temptype);
|
temptype = gfc_get_element_type (temptype);
|
temptype = gfc_get_element_type (temptype);
|
}
|
}
|
|
|
else
|
else
|
/* For class arrays signal that the size of the dynamic type has to
|
/* For class arrays signal that the size of the dynamic type has to
|
be obtained from the vtable, using the 'initial' expression. */
|
be obtained from the vtable, using the 'initial' expression. */
|
temptype = NULL_TREE;
|
temptype = NULL_TREE;
|
|
|
/* Generate the temporary. Cleaning up the temporary should be the
|
/* Generate the temporary. Cleaning up the temporary should be the
|
very last thing done, so we add the code to a new block and add it
|
very last thing done, so we add the code to a new block and add it
|
to se->post as last instructions. */
|
to se->post as last instructions. */
|
size = gfc_create_var (gfc_array_index_type, NULL);
|
size = gfc_create_var (gfc_array_index_type, NULL);
|
data = gfc_create_var (pvoid_type_node, NULL);
|
data = gfc_create_var (pvoid_type_node, NULL);
|
gfc_init_block (&temp_post);
|
gfc_init_block (&temp_post);
|
tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
|
tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
|
temptype, initial, false, true,
|
temptype, initial, false, true,
|
false, &arg->expr->where);
|
false, &arg->expr->where);
|
gfc_add_modify (&se->pre, size, tmp);
|
gfc_add_modify (&se->pre, size, tmp);
|
tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
|
tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
|
gfc_add_modify (&se->pre, data, tmp);
|
gfc_add_modify (&se->pre, data, tmp);
|
|
|
/* Update other ss' delta. */
|
/* Update other ss' delta. */
|
gfc_set_delta (loopse->loop);
|
gfc_set_delta (loopse->loop);
|
|
|
/* Copy the result back using unpack..... */
|
/* Copy the result back using unpack..... */
|
if (e->ts.type != BT_CLASS)
|
if (e->ts.type != BT_CLASS)
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
gfor_fndecl_in_unpack, 2, parmse.expr, data);
|
gfor_fndecl_in_unpack, 2, parmse.expr, data);
|
else
|
else
|
{
|
{
|
/* ... except for class results where the copy is
|
/* ... except for class results where the copy is
|
unconditional. */
|
unconditional. */
|
tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
|
tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
builtin_decl_explicit (BUILT_IN_MEMCPY),
|
builtin_decl_explicit (BUILT_IN_MEMCPY),
|
3, tmp, data, size);
|
3, tmp, data, size);
|
}
|
}
|
gfc_add_expr_to_block (&se->post, tmp);
|
gfc_add_expr_to_block (&se->post, tmp);
|
|
|
/* parmse.pre is already added above. */
|
/* parmse.pre is already added above. */
|
gfc_add_block_to_block (&se->post, &parmse.post);
|
gfc_add_block_to_block (&se->post, &parmse.post);
|
gfc_add_block_to_block (&se->post, &temp_post);
|
gfc_add_block_to_block (&se->post, &temp_post);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Get the interface symbol for the procedure corresponding to the given call.
|
/* Get the interface symbol for the procedure corresponding to the given call.
|
We can't get the procedure symbol directly as we have to handle the case
|
We can't get the procedure symbol directly as we have to handle the case
|
of (deferred) type-bound procedures. */
|
of (deferred) type-bound procedures. */
|
|
|
static gfc_symbol *
|
static gfc_symbol *
|
get_proc_ifc_for_call (gfc_code *c)
|
get_proc_ifc_for_call (gfc_code *c)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
|
|
gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
|
gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
|
|
|
sym = gfc_get_proc_ifc_for_expr (c->expr1);
|
sym = gfc_get_proc_ifc_for_expr (c->expr1);
|
|
|
/* Fall back/last resort try. */
|
/* Fall back/last resort try. */
|
if (sym == NULL)
|
if (sym == NULL)
|
sym = c->resolved_sym;
|
sym = c->resolved_sym;
|
|
|
return sym;
|
return sym;
|
}
|
}
|
|
|
|
|
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
|
/* Translate the CALL statement. Builds a call to an F95 subroutine. */
|
|
|
tree
|
tree
|
gfc_trans_call (gfc_code * code, bool dependency_check,
|
gfc_trans_call (gfc_code * code, bool dependency_check,
|
tree mask, tree count1, bool invert)
|
tree mask, tree count1, bool invert)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
gfc_ss * ss;
|
gfc_ss * ss;
|
int has_alternate_specifier;
|
int has_alternate_specifier;
|
gfc_dep_check check_variable;
|
gfc_dep_check check_variable;
|
tree index = NULL_TREE;
|
tree index = NULL_TREE;
|
tree maskexpr = NULL_TREE;
|
tree maskexpr = NULL_TREE;
|
tree tmp;
|
tree tmp;
|
|
|
/* A CALL starts a new block because the actual arguments may have to
|
/* A CALL starts a new block because the actual arguments may have to
|
be evaluated first. */
|
be evaluated first. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
gcc_assert (code->resolved_sym);
|
gcc_assert (code->resolved_sym);
|
|
|
ss = gfc_ss_terminator;
|
ss = gfc_ss_terminator;
|
if (code->resolved_sym->attr.elemental)
|
if (code->resolved_sym->attr.elemental)
|
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
|
ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
|
get_proc_ifc_for_call (code),
|
get_proc_ifc_for_call (code),
|
GFC_SS_REFERENCE);
|
GFC_SS_REFERENCE);
|
|
|
/* Is not an elemental subroutine call with array valued arguments. */
|
/* Is not an elemental subroutine call with array valued arguments. */
|
if (ss == gfc_ss_terminator)
|
if (ss == gfc_ss_terminator)
|
{
|
{
|
|
|
/* Translate the call. */
|
/* Translate the call. */
|
has_alternate_specifier
|
has_alternate_specifier
|
= gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
|
= gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
|
code->expr1, NULL);
|
code->expr1, NULL);
|
|
|
/* A subroutine without side-effect, by definition, does nothing! */
|
/* A subroutine without side-effect, by definition, does nothing! */
|
TREE_SIDE_EFFECTS (se.expr) = 1;
|
TREE_SIDE_EFFECTS (se.expr) = 1;
|
|
|
/* Chain the pieces together and return the block. */
|
/* Chain the pieces together and return the block. */
|
if (has_alternate_specifier)
|
if (has_alternate_specifier)
|
{
|
{
|
gfc_code *select_code;
|
gfc_code *select_code;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
select_code = code->next;
|
select_code = code->next;
|
gcc_assert(select_code->op == EXEC_SELECT);
|
gcc_assert(select_code->op == EXEC_SELECT);
|
sym = select_code->expr1->symtree->n.sym;
|
sym = select_code->expr1->symtree->n.sym;
|
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
|
se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
|
if (sym->backend_decl == NULL)
|
if (sym->backend_decl == NULL)
|
sym->backend_decl = gfc_get_symbol_decl (sym);
|
sym->backend_decl = gfc_get_symbol_decl (sym);
|
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
|
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
|
}
|
}
|
else
|
else
|
gfc_add_expr_to_block (&se.pre, se.expr);
|
gfc_add_expr_to_block (&se.pre, se.expr);
|
|
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
}
|
}
|
|
|
else
|
else
|
{
|
{
|
/* An elemental subroutine call with array valued arguments has
|
/* An elemental subroutine call with array valued arguments has
|
to be scalarized. */
|
to be scalarized. */
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
stmtblock_t body;
|
stmtblock_t body;
|
stmtblock_t block;
|
stmtblock_t block;
|
gfc_se loopse;
|
gfc_se loopse;
|
gfc_se depse;
|
gfc_se depse;
|
|
|
/* gfc_walk_elemental_function_args renders the ss chain in the
|
/* gfc_walk_elemental_function_args renders the ss chain in the
|
reverse order to the actual argument order. */
|
reverse order to the actual argument order. */
|
ss = gfc_reverse_ss (ss);
|
ss = gfc_reverse_ss (ss);
|
|
|
/* Initialize the loop. */
|
/* Initialize the loop. */
|
gfc_init_se (&loopse, NULL);
|
gfc_init_se (&loopse, NULL);
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
gfc_add_ss_to_loop (&loop, ss);
|
gfc_add_ss_to_loop (&loop, ss);
|
|
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
/* TODO: gfc_conv_loop_setup generates a temporary for vector
|
/* TODO: gfc_conv_loop_setup generates a temporary for vector
|
subscripts. This could be prevented in the elemental case
|
subscripts. This could be prevented in the elemental case
|
as temporaries are handled separatedly
|
as temporaries are handled separatedly
|
(below in gfc_conv_elemental_dependencies). */
|
(below in gfc_conv_elemental_dependencies). */
|
gfc_conv_loop_setup (&loop, &code->expr1->where);
|
gfc_conv_loop_setup (&loop, &code->expr1->where);
|
gfc_mark_ss_chain_used (ss, 1);
|
gfc_mark_ss_chain_used (ss, 1);
|
|
|
/* Convert the arguments, checking for dependencies. */
|
/* Convert the arguments, checking for dependencies. */
|
gfc_copy_loopinfo_to_se (&loopse, &loop);
|
gfc_copy_loopinfo_to_se (&loopse, &loop);
|
loopse.ss = ss;
|
loopse.ss = ss;
|
|
|
/* For operator assignment, do dependency checking. */
|
/* For operator assignment, do dependency checking. */
|
if (dependency_check)
|
if (dependency_check)
|
check_variable = ELEM_CHECK_VARIABLE;
|
check_variable = ELEM_CHECK_VARIABLE;
|
else
|
else
|
check_variable = ELEM_DONT_CHECK_VARIABLE;
|
check_variable = ELEM_DONT_CHECK_VARIABLE;
|
|
|
gfc_init_se (&depse, NULL);
|
gfc_init_se (&depse, NULL);
|
gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
|
gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
|
code->ext.actual, check_variable);
|
code->ext.actual, check_variable);
|
|
|
gfc_add_block_to_block (&loop.pre, &depse.pre);
|
gfc_add_block_to_block (&loop.pre, &depse.pre);
|
gfc_add_block_to_block (&loop.post, &depse.post);
|
gfc_add_block_to_block (&loop.post, &depse.post);
|
|
|
/* Generate the loop body. */
|
/* Generate the loop body. */
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
|
|
if (mask && count1)
|
if (mask && count1)
|
{
|
{
|
/* Form the mask expression according to the mask. */
|
/* Form the mask expression according to the mask. */
|
index = count1;
|
index = count1;
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
if (invert)
|
if (invert)
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
TREE_TYPE (maskexpr), maskexpr);
|
TREE_TYPE (maskexpr), maskexpr);
|
}
|
}
|
|
|
/* Add the subroutine call to the block. */
|
/* Add the subroutine call to the block. */
|
gfc_conv_procedure_call (&loopse, code->resolved_sym,
|
gfc_conv_procedure_call (&loopse, code->resolved_sym,
|
code->ext.actual, code->expr1, NULL);
|
code->ext.actual, code->expr1, NULL);
|
|
|
if (mask && count1)
|
if (mask && count1)
|
{
|
{
|
tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
|
tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&loopse.pre, tmp);
|
gfc_add_expr_to_block (&loopse.pre, tmp);
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type,
|
gfc_array_index_type,
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&loopse.pre, count1, tmp);
|
gfc_add_modify (&loopse.pre, count1, tmp);
|
}
|
}
|
else
|
else
|
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
|
gfc_add_expr_to_block (&loopse.pre, loopse.expr);
|
|
|
gfc_add_block_to_block (&block, &loopse.pre);
|
gfc_add_block_to_block (&block, &loopse.pre);
|
gfc_add_block_to_block (&block, &loopse.post);
|
gfc_add_block_to_block (&block, &loopse.post);
|
|
|
/* Finish up the loop block and the loop. */
|
/* Finish up the loop block and the loop. */
|
gfc_add_expr_to_block (&body, gfc_finish_block (&block));
|
gfc_add_expr_to_block (&body, gfc_finish_block (&block));
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_add_block_to_block (&se.pre, &loop.pre);
|
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, &loop.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
}
|
}
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
/* Translate the RETURN statement. */
|
/* Translate the RETURN statement. */
|
|
|
tree
|
tree
|
gfc_trans_return (gfc_code * code)
|
gfc_trans_return (gfc_code * code)
|
{
|
{
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
tree result;
|
tree result;
|
|
|
/* If code->expr is not NULL, this return statement must appear
|
/* If code->expr is not NULL, this return statement must appear
|
in a subroutine and current_fake_result_decl has already
|
in a subroutine and current_fake_result_decl has already
|
been generated. */
|
been generated. */
|
|
|
result = gfc_get_fake_result_decl (NULL, 0);
|
result = gfc_get_fake_result_decl (NULL, 0);
|
if (!result)
|
if (!result)
|
{
|
{
|
gfc_warning ("An alternate return at %L without a * dummy argument",
|
gfc_warning ("An alternate return at %L without a * dummy argument",
|
&code->expr1->where);
|
&code->expr1->where);
|
return gfc_generate_return ();
|
return gfc_generate_return ();
|
}
|
}
|
|
|
/* Start a new block for this statement. */
|
/* Start a new block for this statement. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
gfc_conv_expr (&se, code->expr1);
|
gfc_conv_expr (&se, code->expr1);
|
|
|
/* Note that the actually returned expression is a simple value and
|
/* Note that the actually returned expression is a simple value and
|
does not depend on any pointers or such; thus we can clean-up with
|
does not depend on any pointers or such; thus we can clean-up with
|
se.post before returning. */
|
se.post before returning. */
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
|
result, fold_convert (TREE_TYPE (result),
|
result, fold_convert (TREE_TYPE (result),
|
se.expr));
|
se.expr));
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
|
|
tmp = gfc_generate_return ();
|
tmp = gfc_generate_return ();
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
return gfc_generate_return ();
|
return gfc_generate_return ();
|
}
|
}
|
|
|
|
|
/* Translate the PAUSE statement. We have to translate this statement
|
/* Translate the PAUSE statement. We have to translate this statement
|
to a runtime library call. */
|
to a runtime library call. */
|
|
|
tree
|
tree
|
gfc_trans_pause (gfc_code * code)
|
gfc_trans_pause (gfc_code * code)
|
{
|
{
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
|
|
/* Start a new block for this statement. */
|
/* Start a new block for this statement. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
|
|
if (code->expr1 == NULL)
|
if (code->expr1 == NULL)
|
{
|
{
|
tmp = build_int_cst (gfc_int4_type_node, 0);
|
tmp = build_int_cst (gfc_int4_type_node, 0);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
gfor_fndecl_pause_string, 2,
|
gfor_fndecl_pause_string, 2,
|
build_int_cst (pchar_type_node, 0), tmp);
|
build_int_cst (pchar_type_node, 0), tmp);
|
}
|
}
|
else if (code->expr1->ts.type == BT_INTEGER)
|
else if (code->expr1->ts.type == BT_INTEGER)
|
{
|
{
|
gfc_conv_expr (&se, code->expr1);
|
gfc_conv_expr (&se, code->expr1);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
gfor_fndecl_pause_numeric, 1,
|
gfor_fndecl_pause_numeric, 1,
|
fold_convert (gfc_int4_type_node, se.expr));
|
fold_convert (gfc_int4_type_node, se.expr));
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_conv_expr_reference (&se, code->expr1);
|
gfc_conv_expr_reference (&se, code->expr1);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
gfor_fndecl_pause_string, 2,
|
gfor_fndecl_pause_string, 2,
|
se.expr, se.string_length);
|
se.expr, se.string_length);
|
}
|
}
|
|
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
/* Translate the STOP statement. We have to translate this statement
|
/* Translate the STOP statement. We have to translate this statement
|
to a runtime library call. */
|
to a runtime library call. */
|
|
|
tree
|
tree
|
gfc_trans_stop (gfc_code *code, bool error_stop)
|
gfc_trans_stop (gfc_code *code, bool error_stop)
|
{
|
{
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
|
|
/* Start a new block for this statement. */
|
/* Start a new block for this statement. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
|
{
|
{
|
/* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
|
/* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
|
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
|
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
|
tmp = build_call_expr_loc (input_location, tmp, 0);
|
tmp = build_call_expr_loc (input_location, tmp, 0);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
|
|
if (code->expr1 == NULL)
|
if (code->expr1 == NULL)
|
{
|
{
|
tmp = build_int_cst (gfc_int4_type_node, 0);
|
tmp = build_int_cst (gfc_int4_type_node, 0);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
error_stop
|
error_stop
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? gfor_fndecl_caf_error_stop_str
|
? gfor_fndecl_caf_error_stop_str
|
: gfor_fndecl_error_stop_string)
|
: gfor_fndecl_error_stop_string)
|
: gfor_fndecl_stop_string,
|
: gfor_fndecl_stop_string,
|
2, build_int_cst (pchar_type_node, 0), tmp);
|
2, build_int_cst (pchar_type_node, 0), tmp);
|
}
|
}
|
else if (code->expr1->ts.type == BT_INTEGER)
|
else if (code->expr1->ts.type == BT_INTEGER)
|
{
|
{
|
gfc_conv_expr (&se, code->expr1);
|
gfc_conv_expr (&se, code->expr1);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
error_stop
|
error_stop
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? gfor_fndecl_caf_error_stop
|
? gfor_fndecl_caf_error_stop
|
: gfor_fndecl_error_stop_numeric)
|
: gfor_fndecl_error_stop_numeric)
|
: gfor_fndecl_stop_numeric_f08, 1,
|
: gfor_fndecl_stop_numeric_f08, 1,
|
fold_convert (gfc_int4_type_node, se.expr));
|
fold_convert (gfc_int4_type_node, se.expr));
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_conv_expr_reference (&se, code->expr1);
|
gfc_conv_expr_reference (&se, code->expr1);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
error_stop
|
error_stop
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? (gfc_option.coarray == GFC_FCOARRAY_LIB
|
? gfor_fndecl_caf_error_stop_str
|
? gfor_fndecl_caf_error_stop_str
|
: gfor_fndecl_error_stop_string)
|
: gfor_fndecl_error_stop_string)
|
: gfor_fndecl_stop_string,
|
: gfor_fndecl_stop_string,
|
2, se.expr, se.string_length);
|
2, se.expr, se.string_length);
|
}
|
}
|
|
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
gfc_add_block_to_block (&se.pre, &se.post);
|
gfc_add_block_to_block (&se.pre, &se.post);
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
tree
|
tree
|
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
|
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
|
{
|
{
|
gfc_se se, argse;
|
gfc_se se, argse;
|
tree stat = NULL_TREE, lock_acquired = NULL_TREE;
|
tree stat = NULL_TREE, lock_acquired = NULL_TREE;
|
|
|
/* Short cut: For single images without STAT= or LOCK_ACQUIRED
|
/* Short cut: For single images without STAT= or LOCK_ACQUIRED
|
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
|
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
|
if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
|
if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
|
return NULL_TREE;
|
return NULL_TREE;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
if (code->expr2)
|
if (code->expr2)
|
{
|
{
|
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
|
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
|
gfc_init_se (&argse, NULL);
|
gfc_init_se (&argse, NULL);
|
gfc_conv_expr_val (&argse, code->expr2);
|
gfc_conv_expr_val (&argse, code->expr2);
|
stat = argse.expr;
|
stat = argse.expr;
|
}
|
}
|
|
|
if (code->expr4)
|
if (code->expr4)
|
{
|
{
|
gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
|
gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
|
gfc_init_se (&argse, NULL);
|
gfc_init_se (&argse, NULL);
|
gfc_conv_expr_val (&argse, code->expr4);
|
gfc_conv_expr_val (&argse, code->expr4);
|
lock_acquired = argse.expr;
|
lock_acquired = argse.expr;
|
}
|
}
|
|
|
if (stat != NULL_TREE)
|
if (stat != NULL_TREE)
|
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
|
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
|
|
|
if (lock_acquired != NULL_TREE)
|
if (lock_acquired != NULL_TREE)
|
gfc_add_modify (&se.pre, lock_acquired,
|
gfc_add_modify (&se.pre, lock_acquired,
|
fold_convert (TREE_TYPE (lock_acquired),
|
fold_convert (TREE_TYPE (lock_acquired),
|
boolean_true_node));
|
boolean_true_node));
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
tree
|
tree
|
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
|
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
|
{
|
{
|
gfc_se se, argse;
|
gfc_se se, argse;
|
tree tmp;
|
tree tmp;
|
tree images = NULL_TREE, stat = NULL_TREE,
|
tree images = NULL_TREE, stat = NULL_TREE,
|
errmsg = NULL_TREE, errmsglen = NULL_TREE;
|
errmsg = NULL_TREE, errmsglen = NULL_TREE;
|
|
|
/* Short cut: For single images without bound checking or without STAT=,
|
/* Short cut: For single images without bound checking or without STAT=,
|
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
|
return early. (ERRMSG= is always untouched for -fcoarray=single.) */
|
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
&& gfc_option.coarray != GFC_FCOARRAY_LIB)
|
&& gfc_option.coarray != GFC_FCOARRAY_LIB)
|
return NULL_TREE;
|
return NULL_TREE;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
if (code->expr1 && code->expr1->rank == 0)
|
if (code->expr1 && code->expr1->rank == 0)
|
{
|
{
|
gfc_init_se (&argse, NULL);
|
gfc_init_se (&argse, NULL);
|
gfc_conv_expr_val (&argse, code->expr1);
|
gfc_conv_expr_val (&argse, code->expr1);
|
images = argse.expr;
|
images = argse.expr;
|
}
|
}
|
|
|
if (code->expr2)
|
if (code->expr2)
|
{
|
{
|
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
|
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
|
gfc_init_se (&argse, NULL);
|
gfc_init_se (&argse, NULL);
|
gfc_conv_expr_val (&argse, code->expr2);
|
gfc_conv_expr_val (&argse, code->expr2);
|
stat = argse.expr;
|
stat = argse.expr;
|
}
|
}
|
else
|
else
|
stat = null_pointer_node;
|
stat = null_pointer_node;
|
|
|
if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
|
if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
|
&& type != EXEC_SYNC_MEMORY)
|
&& type != EXEC_SYNC_MEMORY)
|
{
|
{
|
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
|
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
|
gfc_init_se (&argse, NULL);
|
gfc_init_se (&argse, NULL);
|
gfc_conv_expr (&argse, code->expr3);
|
gfc_conv_expr (&argse, code->expr3);
|
gfc_conv_string_parameter (&argse);
|
gfc_conv_string_parameter (&argse);
|
errmsg = gfc_build_addr_expr (NULL, argse.expr);
|
errmsg = gfc_build_addr_expr (NULL, argse.expr);
|
errmsglen = argse.string_length;
|
errmsglen = argse.string_length;
|
}
|
}
|
else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
|
else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
|
{
|
{
|
errmsg = null_pointer_node;
|
errmsg = null_pointer_node;
|
errmsglen = build_int_cst (integer_type_node, 0);
|
errmsglen = build_int_cst (integer_type_node, 0);
|
}
|
}
|
|
|
/* Check SYNC IMAGES(imageset) for valid image index.
|
/* Check SYNC IMAGES(imageset) for valid image index.
|
FIXME: Add a check for image-set arrays. */
|
FIXME: Add a check for image-set arrays. */
|
if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
&& code->expr1->rank == 0)
|
&& code->expr1->rank == 0)
|
{
|
{
|
tree cond;
|
tree cond;
|
if (gfc_option.coarray != GFC_FCOARRAY_LIB)
|
if (gfc_option.coarray != GFC_FCOARRAY_LIB)
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
images, build_int_cst (TREE_TYPE (images), 1));
|
images, build_int_cst (TREE_TYPE (images), 1));
|
else
|
else
|
{
|
{
|
tree cond2;
|
tree cond2;
|
cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
|
cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
|
images, gfort_gvar_caf_num_images);
|
images, gfort_gvar_caf_num_images);
|
cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
images,
|
images,
|
build_int_cst (TREE_TYPE (images), 1));
|
build_int_cst (TREE_TYPE (images), 1));
|
cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
|
cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
|
boolean_type_node, cond, cond2);
|
boolean_type_node, cond, cond2);
|
}
|
}
|
gfc_trans_runtime_check (true, false, cond, &se.pre,
|
gfc_trans_runtime_check (true, false, cond, &se.pre,
|
&code->expr1->where, "Invalid image number "
|
&code->expr1->where, "Invalid image number "
|
"%d in SYNC IMAGES",
|
"%d in SYNC IMAGES",
|
fold_convert (integer_type_node, se.expr));
|
fold_convert (integer_type_node, se.expr));
|
}
|
}
|
|
|
/* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
|
/* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
|
image control statements SYNC IMAGES and SYNC ALL. */
|
image control statements SYNC IMAGES and SYNC ALL. */
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
{
|
{
|
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
|
tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
|
tmp = build_call_expr_loc (input_location, tmp, 0);
|
tmp = build_call_expr_loc (input_location, tmp, 0);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
|
|
if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
|
if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
|
{
|
{
|
/* Set STAT to zero. */
|
/* Set STAT to zero. */
|
if (code->expr2)
|
if (code->expr2)
|
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
|
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
|
}
|
}
|
else if (type == EXEC_SYNC_ALL)
|
else if (type == EXEC_SYNC_ALL)
|
{
|
{
|
/* SYNC ALL => stat == null_pointer_node
|
/* SYNC ALL => stat == null_pointer_node
|
SYNC ALL(stat=s) => stat has an integer type
|
SYNC ALL(stat=s) => stat has an integer type
|
|
|
If "stat" has the wrong integer type, use a temp variable of
|
If "stat" has the wrong integer type, use a temp variable of
|
the right type and later cast the result back into "stat". */
|
the right type and later cast the result back into "stat". */
|
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
|
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
|
{
|
{
|
if (TREE_TYPE (stat) == integer_type_node)
|
if (TREE_TYPE (stat) == integer_type_node)
|
stat = gfc_build_addr_expr (NULL, stat);
|
stat = gfc_build_addr_expr (NULL, stat);
|
|
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
|
3, stat, errmsg, errmsglen);
|
3, stat, errmsg, errmsglen);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
|
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
|
|
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
|
3, gfc_build_addr_expr (NULL, tmp_stat),
|
3, gfc_build_addr_expr (NULL, tmp_stat),
|
errmsg, errmsglen);
|
errmsg, errmsglen);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
gfc_add_modify (&se.pre, stat,
|
gfc_add_modify (&se.pre, stat,
|
fold_convert (TREE_TYPE (stat), tmp_stat));
|
fold_convert (TREE_TYPE (stat), tmp_stat));
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
tree len;
|
tree len;
|
|
|
gcc_assert (type == EXEC_SYNC_IMAGES);
|
gcc_assert (type == EXEC_SYNC_IMAGES);
|
|
|
if (!code->expr1)
|
if (!code->expr1)
|
{
|
{
|
len = build_int_cst (integer_type_node, -1);
|
len = build_int_cst (integer_type_node, -1);
|
images = null_pointer_node;
|
images = null_pointer_node;
|
}
|
}
|
else if (code->expr1->rank == 0)
|
else if (code->expr1->rank == 0)
|
{
|
{
|
len = build_int_cst (integer_type_node, 1);
|
len = build_int_cst (integer_type_node, 1);
|
images = gfc_build_addr_expr (NULL_TREE, images);
|
images = gfc_build_addr_expr (NULL_TREE, images);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* FIXME. */
|
/* FIXME. */
|
if (code->expr1->ts.kind != gfc_c_int_kind)
|
if (code->expr1->ts.kind != gfc_c_int_kind)
|
gfc_fatal_error ("Sorry, only support for integer kind %d "
|
gfc_fatal_error ("Sorry, only support for integer kind %d "
|
"implemented for image-set at %L",
|
"implemented for image-set at %L",
|
gfc_c_int_kind, &code->expr1->where);
|
gfc_c_int_kind, &code->expr1->where);
|
|
|
gfc_conv_array_parameter (&se, code->expr1,
|
gfc_conv_array_parameter (&se, code->expr1,
|
gfc_walk_expr (code->expr1), true, NULL,
|
gfc_walk_expr (code->expr1), true, NULL,
|
NULL, &len);
|
NULL, &len);
|
images = se.expr;
|
images = se.expr;
|
|
|
tmp = gfc_typenode_for_spec (&code->expr1->ts);
|
tmp = gfc_typenode_for_spec (&code->expr1->ts);
|
if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
|
if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
|
tmp = gfc_get_element_type (tmp);
|
tmp = gfc_get_element_type (tmp);
|
|
|
len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
TREE_TYPE (len), len,
|
TREE_TYPE (len), len,
|
fold_convert (TREE_TYPE (len),
|
fold_convert (TREE_TYPE (len),
|
TYPE_SIZE_UNIT (tmp)));
|
TYPE_SIZE_UNIT (tmp)));
|
len = fold_convert (integer_type_node, len);
|
len = fold_convert (integer_type_node, len);
|
}
|
}
|
|
|
/* SYNC IMAGES(imgs) => stat == null_pointer_node
|
/* SYNC IMAGES(imgs) => stat == null_pointer_node
|
SYNC IMAGES(imgs,stat=s) => stat has an integer type
|
SYNC IMAGES(imgs,stat=s) => stat has an integer type
|
|
|
If "stat" has the wrong integer type, use a temp variable of
|
If "stat" has the wrong integer type, use a temp variable of
|
the right type and later cast the result back into "stat". */
|
the right type and later cast the result back into "stat". */
|
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
|
if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
|
{
|
{
|
if (TREE_TYPE (stat) == integer_type_node)
|
if (TREE_TYPE (stat) == integer_type_node)
|
stat = gfc_build_addr_expr (NULL, stat);
|
stat = gfc_build_addr_expr (NULL, stat);
|
|
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
|
5, fold_convert (integer_type_node, len),
|
5, fold_convert (integer_type_node, len),
|
images, stat, errmsg, errmsglen);
|
images, stat, errmsg, errmsglen);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
|
tree tmp_stat = gfc_create_var (integer_type_node, "stat");
|
|
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
|
5, fold_convert (integer_type_node, len),
|
5, fold_convert (integer_type_node, len),
|
images, gfc_build_addr_expr (NULL, tmp_stat),
|
images, gfc_build_addr_expr (NULL, tmp_stat),
|
errmsg, errmsglen);
|
errmsg, errmsglen);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
gfc_add_modify (&se.pre, stat,
|
gfc_add_modify (&se.pre, stat,
|
fold_convert (TREE_TYPE (stat), tmp_stat));
|
fold_convert (TREE_TYPE (stat), tmp_stat));
|
}
|
}
|
}
|
}
|
|
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
/* Generate GENERIC for the IF construct. This function also deals with
|
/* Generate GENERIC for the IF construct. This function also deals with
|
the simple IF statement, because the front end translates the IF
|
the simple IF statement, because the front end translates the IF
|
statement into an IF construct.
|
statement into an IF construct.
|
|
|
We translate:
|
We translate:
|
|
|
IF (cond) THEN
|
IF (cond) THEN
|
then_clause
|
then_clause
|
ELSEIF (cond2)
|
ELSEIF (cond2)
|
elseif_clause
|
elseif_clause
|
ELSE
|
ELSE
|
else_clause
|
else_clause
|
ENDIF
|
ENDIF
|
|
|
into:
|
into:
|
|
|
pre_cond_s;
|
pre_cond_s;
|
if (cond_s)
|
if (cond_s)
|
{
|
{
|
then_clause;
|
then_clause;
|
}
|
}
|
else
|
else
|
{
|
{
|
pre_cond_s
|
pre_cond_s
|
if (cond_s)
|
if (cond_s)
|
{
|
{
|
elseif_clause
|
elseif_clause
|
}
|
}
|
else
|
else
|
{
|
{
|
else_clause;
|
else_clause;
|
}
|
}
|
}
|
}
|
|
|
where COND_S is the simplified version of the predicate. PRE_COND_S
|
where COND_S is the simplified version of the predicate. PRE_COND_S
|
are the pre side-effects produced by the translation of the
|
are the pre side-effects produced by the translation of the
|
conditional.
|
conditional.
|
We need to build the chain recursively otherwise we run into
|
We need to build the chain recursively otherwise we run into
|
problems with folding incomplete statements. */
|
problems with folding incomplete statements. */
|
|
|
static tree
|
static tree
|
gfc_trans_if_1 (gfc_code * code)
|
gfc_trans_if_1 (gfc_code * code)
|
{
|
{
|
gfc_se if_se;
|
gfc_se if_se;
|
tree stmt, elsestmt;
|
tree stmt, elsestmt;
|
locus saved_loc;
|
locus saved_loc;
|
location_t loc;
|
location_t loc;
|
|
|
/* Check for an unconditional ELSE clause. */
|
/* Check for an unconditional ELSE clause. */
|
if (!code->expr1)
|
if (!code->expr1)
|
return gfc_trans_code (code->next);
|
return gfc_trans_code (code->next);
|
|
|
/* Initialize a statement builder for each block. Puts in NULL_TREEs. */
|
/* Initialize a statement builder for each block. Puts in NULL_TREEs. */
|
gfc_init_se (&if_se, NULL);
|
gfc_init_se (&if_se, NULL);
|
gfc_start_block (&if_se.pre);
|
gfc_start_block (&if_se.pre);
|
|
|
/* Calculate the IF condition expression. */
|
/* Calculate the IF condition expression. */
|
if (code->expr1->where.lb)
|
if (code->expr1->where.lb)
|
{
|
{
|
gfc_save_backend_locus (&saved_loc);
|
gfc_save_backend_locus (&saved_loc);
|
gfc_set_backend_locus (&code->expr1->where);
|
gfc_set_backend_locus (&code->expr1->where);
|
}
|
}
|
|
|
gfc_conv_expr_val (&if_se, code->expr1);
|
gfc_conv_expr_val (&if_se, code->expr1);
|
|
|
if (code->expr1->where.lb)
|
if (code->expr1->where.lb)
|
gfc_restore_backend_locus (&saved_loc);
|
gfc_restore_backend_locus (&saved_loc);
|
|
|
/* Translate the THEN clause. */
|
/* Translate the THEN clause. */
|
stmt = gfc_trans_code (code->next);
|
stmt = gfc_trans_code (code->next);
|
|
|
/* Translate the ELSE clause. */
|
/* Translate the ELSE clause. */
|
if (code->block)
|
if (code->block)
|
elsestmt = gfc_trans_if_1 (code->block);
|
elsestmt = gfc_trans_if_1 (code->block);
|
else
|
else
|
elsestmt = build_empty_stmt (input_location);
|
elsestmt = build_empty_stmt (input_location);
|
|
|
/* Build the condition expression and add it to the condition block. */
|
/* Build the condition expression and add it to the condition block. */
|
loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
|
loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
|
stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
|
stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
|
elsestmt);
|
elsestmt);
|
|
|
gfc_add_expr_to_block (&if_se.pre, stmt);
|
gfc_add_expr_to_block (&if_se.pre, stmt);
|
|
|
/* Finish off this statement. */
|
/* Finish off this statement. */
|
return gfc_finish_block (&if_se.pre);
|
return gfc_finish_block (&if_se.pre);
|
}
|
}
|
|
|
tree
|
tree
|
gfc_trans_if (gfc_code * code)
|
gfc_trans_if (gfc_code * code)
|
{
|
{
|
stmtblock_t body;
|
stmtblock_t body;
|
tree exit_label;
|
tree exit_label;
|
|
|
/* Create exit label so it is available for trans'ing the body code. */
|
/* Create exit label so it is available for trans'ing the body code. */
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
|
|
/* Translate the actual code in code->block. */
|
/* Translate the actual code in code->block. */
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
|
gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
|
|
|
/* Add exit label. */
|
/* Add exit label. */
|
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
|
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
|
|
|
return gfc_finish_block (&body);
|
return gfc_finish_block (&body);
|
}
|
}
|
|
|
|
|
/* Translate an arithmetic IF expression.
|
/* Translate an arithmetic IF expression.
|
|
|
IF (cond) label1, label2, label3 translates to
|
IF (cond) label1, label2, label3 translates to
|
|
|
if (cond <= 0)
|
if (cond <= 0)
|
{
|
{
|
if (cond < 0)
|
if (cond < 0)
|
goto label1;
|
goto label1;
|
else // cond == 0
|
else // cond == 0
|
goto label2;
|
goto label2;
|
}
|
}
|
else // cond > 0
|
else // cond > 0
|
goto label3;
|
goto label3;
|
|
|
An optimized version can be generated in case of equal labels.
|
An optimized version can be generated in case of equal labels.
|
E.g., if label1 is equal to label2, we can translate it to
|
E.g., if label1 is equal to label2, we can translate it to
|
|
|
if (cond <= 0)
|
if (cond <= 0)
|
goto label1;
|
goto label1;
|
else
|
else
|
goto label3;
|
goto label3;
|
*/
|
*/
|
|
|
tree
|
tree
|
gfc_trans_arithmetic_if (gfc_code * code)
|
gfc_trans_arithmetic_if (gfc_code * code)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
tree branch1;
|
tree branch1;
|
tree branch2;
|
tree branch2;
|
tree zero;
|
tree zero;
|
|
|
/* Start a new block. */
|
/* Start a new block. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
/* Pre-evaluate COND. */
|
/* Pre-evaluate COND. */
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_conv_expr_val (&se, code->expr1);
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
|
|
/* Build something to compare with. */
|
/* Build something to compare with. */
|
zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
|
zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
|
|
|
if (code->label1->value != code->label2->value)
|
if (code->label1->value != code->label2->value)
|
{
|
{
|
/* If (cond < 0) take branch1 else take branch2.
|
/* If (cond < 0) take branch1 else take branch2.
|
First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
|
First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
|
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
|
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
|
|
|
if (code->label1->value != code->label3->value)
|
if (code->label1->value != code->label3->value)
|
tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
se.expr, zero);
|
se.expr, zero);
|
else
|
else
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
se.expr, zero);
|
se.expr, zero);
|
|
|
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp, branch1, branch2);
|
tmp, branch1, branch2);
|
}
|
}
|
else
|
else
|
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
|
|
|
if (code->label1->value != code->label3->value
|
if (code->label1->value != code->label3->value
|
&& code->label2->value != code->label3->value)
|
&& code->label2->value != code->label3->value)
|
{
|
{
|
/* if (cond <= 0) take branch1 else take branch2. */
|
/* if (cond <= 0) take branch1 else take branch2. */
|
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
|
branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
|
tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
|
tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
|
se.expr, zero);
|
se.expr, zero);
|
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp, branch1, branch2);
|
tmp, branch1, branch2);
|
}
|
}
|
|
|
/* Append the COND_EXPR to the evaluation of COND, and return. */
|
/* Append the COND_EXPR to the evaluation of COND, and return. */
|
gfc_add_expr_to_block (&se.pre, branch1);
|
gfc_add_expr_to_block (&se.pre, branch1);
|
return gfc_finish_block (&se.pre);
|
return gfc_finish_block (&se.pre);
|
}
|
}
|
|
|
|
|
/* Translate a CRITICAL block. */
|
/* Translate a CRITICAL block. */
|
tree
|
tree
|
gfc_trans_critical (gfc_code *code)
|
gfc_trans_critical (gfc_code *code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
tree tmp;
|
tree tmp;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
{
|
{
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
tmp = gfc_trans_code (code->block->next);
|
tmp = gfc_trans_code (code->block->next);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
if (gfc_option.coarray == GFC_FCOARRAY_LIB)
|
{
|
{
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
|
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
|
0);
|
0);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Do proper initialization for ASSOCIATE names. */
|
/* Do proper initialization for ASSOCIATE names. */
|
|
|
static void
|
static void
|
trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
tree tmp;
|
tree tmp;
|
bool class_target;
|
bool class_target;
|
|
|
gcc_assert (sym->assoc);
|
gcc_assert (sym->assoc);
|
e = sym->assoc->target;
|
e = sym->assoc->target;
|
|
|
class_target = (e->expr_type == EXPR_VARIABLE)
|
class_target = (e->expr_type == EXPR_VARIABLE)
|
&& (gfc_is_class_scalar_expr (e)
|
&& (gfc_is_class_scalar_expr (e)
|
|| gfc_is_class_array_ref (e, NULL));
|
|| gfc_is_class_array_ref (e, NULL));
|
|
|
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
|
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
|
to array temporary) for arrays with either unknown shape or if associating
|
to array temporary) for arrays with either unknown shape or if associating
|
to a variable. */
|
to a variable. */
|
if (sym->attr.dimension && !class_target
|
if (sym->attr.dimension && !class_target
|
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
|
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
gfc_ss *ss;
|
gfc_ss *ss;
|
tree desc;
|
tree desc;
|
|
|
desc = sym->backend_decl;
|
desc = sym->backend_decl;
|
|
|
/* If association is to an expression, evaluate it and create temporary.
|
/* If association is to an expression, evaluate it and create temporary.
|
Otherwise, get descriptor of target for pointer assignment. */
|
Otherwise, get descriptor of target for pointer assignment. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
ss = gfc_walk_expr (e);
|
ss = gfc_walk_expr (e);
|
if (sym->assoc->variable)
|
if (sym->assoc->variable)
|
{
|
{
|
se.direct_byref = 1;
|
se.direct_byref = 1;
|
se.expr = desc;
|
se.expr = desc;
|
}
|
}
|
gfc_conv_expr_descriptor (&se, e, ss);
|
gfc_conv_expr_descriptor (&se, e, ss);
|
|
|
/* If we didn't already do the pointer assignment, set associate-name
|
/* If we didn't already do the pointer assignment, set associate-name
|
descriptor to the one generated for the temporary. */
|
descriptor to the one generated for the temporary. */
|
if (!sym->assoc->variable)
|
if (!sym->assoc->variable)
|
{
|
{
|
int dim;
|
int dim;
|
|
|
gfc_add_modify (&se.pre, desc, se.expr);
|
gfc_add_modify (&se.pre, desc, se.expr);
|
|
|
/* The generated descriptor has lower bound zero (as array
|
/* The generated descriptor has lower bound zero (as array
|
temporary), shift bounds so we get lower bounds of 1. */
|
temporary), shift bounds so we get lower bounds of 1. */
|
for (dim = 0; dim < e->rank; ++dim)
|
for (dim = 0; dim < e->rank; ++dim)
|
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
|
gfc_conv_shift_descriptor_lbound (&se.pre, desc,
|
dim, gfc_index_one_node);
|
dim, gfc_index_one_node);
|
}
|
}
|
|
|
/* Done, register stuff as init / cleanup code. */
|
/* Done, register stuff as init / cleanup code. */
|
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
|
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
|
gfc_finish_block (&se.post));
|
gfc_finish_block (&se.post));
|
}
|
}
|
|
|
/* CLASS arrays just need the descriptor to be directly assigned. */
|
/* CLASS arrays just need the descriptor to be directly assigned. */
|
else if (class_target && sym->attr.dimension)
|
else if (class_target && sym->attr.dimension)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
se.descriptor_only = 1;
|
se.descriptor_only = 1;
|
gfc_conv_expr (&se, e);
|
gfc_conv_expr (&se, e);
|
|
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
|
|
|
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
|
gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
|
|
|
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
|
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
|
gfc_finish_block (&se.post));
|
gfc_finish_block (&se.post));
|
}
|
}
|
|
|
/* Do a scalar pointer assignment; this is for scalar variable targets. */
|
/* Do a scalar pointer assignment; this is for scalar variable targets. */
|
else if (gfc_is_associate_pointer (sym))
|
else if (gfc_is_associate_pointer (sym))
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
|
|
gcc_assert (!sym->attr.dimension);
|
gcc_assert (!sym->attr.dimension);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr (&se, e);
|
gfc_conv_expr (&se, e);
|
|
|
tmp = TREE_TYPE (sym->backend_decl);
|
tmp = TREE_TYPE (sym->backend_decl);
|
tmp = gfc_build_addr_expr (tmp, se.expr);
|
tmp = gfc_build_addr_expr (tmp, se.expr);
|
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
|
gfc_add_modify (&se.pre, sym->backend_decl, tmp);
|
|
|
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
|
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
|
gfc_finish_block (&se.post));
|
gfc_finish_block (&se.post));
|
}
|
}
|
|
|
/* Do a simple assignment. This is for scalar expressions, where we
|
/* Do a simple assignment. This is for scalar expressions, where we
|
can simply use expression assignment. */
|
can simply use expression assignment. */
|
else
|
else
|
{
|
{
|
gfc_expr *lhs;
|
gfc_expr *lhs;
|
|
|
lhs = gfc_lval_expr_from_sym (sym);
|
lhs = gfc_lval_expr_from_sym (sym);
|
tmp = gfc_trans_assignment (lhs, e, false, true);
|
tmp = gfc_trans_assignment (lhs, e, false, true);
|
gfc_add_init_cleanup (block, tmp, NULL_TREE);
|
gfc_add_init_cleanup (block, tmp, NULL_TREE);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Translate a BLOCK construct. This is basically what we would do for a
|
/* Translate a BLOCK construct. This is basically what we would do for a
|
procedure body. */
|
procedure body. */
|
|
|
tree
|
tree
|
gfc_trans_block_construct (gfc_code* code)
|
gfc_trans_block_construct (gfc_code* code)
|
{
|
{
|
gfc_namespace* ns;
|
gfc_namespace* ns;
|
gfc_symbol* sym;
|
gfc_symbol* sym;
|
gfc_wrapped_block block;
|
gfc_wrapped_block block;
|
tree exit_label;
|
tree exit_label;
|
stmtblock_t body;
|
stmtblock_t body;
|
gfc_association_list *ass;
|
gfc_association_list *ass;
|
|
|
ns = code->ext.block.ns;
|
ns = code->ext.block.ns;
|
gcc_assert (ns);
|
gcc_assert (ns);
|
sym = ns->proc_name;
|
sym = ns->proc_name;
|
gcc_assert (sym);
|
gcc_assert (sym);
|
|
|
/* Process local variables. */
|
/* Process local variables. */
|
gcc_assert (!sym->tlink);
|
gcc_assert (!sym->tlink);
|
sym->tlink = sym;
|
sym->tlink = sym;
|
gfc_process_block_locals (ns);
|
gfc_process_block_locals (ns);
|
|
|
/* Generate code including exit-label. */
|
/* Generate code including exit-label. */
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
|
gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
|
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
|
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
|
|
|
/* Finish everything. */
|
/* Finish everything. */
|
gfc_start_wrapped_block (&block, gfc_finish_block (&body));
|
gfc_start_wrapped_block (&block, gfc_finish_block (&body));
|
gfc_trans_deferred_vars (sym, &block);
|
gfc_trans_deferred_vars (sym, &block);
|
for (ass = code->ext.block.assoc; ass; ass = ass->next)
|
for (ass = code->ext.block.assoc; ass; ass = ass->next)
|
trans_associate_var (ass->st->n.sym, &block);
|
trans_associate_var (ass->st->n.sym, &block);
|
|
|
return gfc_finish_wrapped_block (&block);
|
return gfc_finish_wrapped_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the simple DO construct. This is where the loop variable has
|
/* 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
|
integer type and step +-1. We can't use this in the general case
|
because integer overflow and floating point errors could give incorrect
|
because integer overflow and floating point errors could give incorrect
|
results.
|
results.
|
We translate a do loop from:
|
We translate a do loop from:
|
|
|
DO dovar = from, to, step
|
DO dovar = from, to, step
|
body
|
body
|
END DO
|
END DO
|
|
|
to:
|
to:
|
|
|
[Evaluate loop bounds and step]
|
[Evaluate loop bounds and step]
|
dovar = from;
|
dovar = from;
|
if ((step > 0) ? (dovar <= to) : (dovar => to))
|
if ((step > 0) ? (dovar <= to) : (dovar => to))
|
{
|
{
|
for (;;)
|
for (;;)
|
{
|
{
|
body;
|
body;
|
cycle_label:
|
cycle_label:
|
cond = (dovar == to);
|
cond = (dovar == to);
|
dovar += step;
|
dovar += step;
|
if (cond) goto end_label;
|
if (cond) goto end_label;
|
}
|
}
|
}
|
}
|
end_label:
|
end_label:
|
|
|
This helps the optimizers by avoiding the extra induction variable
|
This helps the optimizers by avoiding the extra induction variable
|
used in the general case. */
|
used in the general case. */
|
|
|
static tree
|
static tree
|
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
|
gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
|
tree from, tree to, tree step, tree exit_cond)
|
tree from, tree to, tree step, tree exit_cond)
|
{
|
{
|
stmtblock_t body;
|
stmtblock_t body;
|
tree type;
|
tree type;
|
tree cond;
|
tree cond;
|
tree tmp;
|
tree tmp;
|
tree saved_dovar = NULL;
|
tree saved_dovar = NULL;
|
tree cycle_label;
|
tree cycle_label;
|
tree exit_label;
|
tree exit_label;
|
location_t loc;
|
location_t loc;
|
|
|
type = TREE_TYPE (dovar);
|
type = TREE_TYPE (dovar);
|
|
|
loc = code->ext.iterator->start->where.lb->location;
|
loc = code->ext.iterator->start->where.lb->location;
|
|
|
/* Initialize the DO variable: dovar = from. */
|
/* Initialize the DO variable: dovar = from. */
|
gfc_add_modify_loc (loc, pblock, dovar,
|
gfc_add_modify_loc (loc, pblock, dovar,
|
fold_convert (TREE_TYPE(dovar), from));
|
fold_convert (TREE_TYPE(dovar), from));
|
|
|
/* Save value for do-tinkering checking. */
|
/* Save value for do-tinkering checking. */
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
{
|
{
|
saved_dovar = gfc_create_var (type, ".saved_dovar");
|
saved_dovar = gfc_create_var (type, ".saved_dovar");
|
gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
|
gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
|
}
|
}
|
|
|
/* Cycle and exit statements are implemented with gotos. */
|
/* Cycle and exit statements are implemented with gotos. */
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
exit_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(). */
|
/* Put the labels where they can be found later. See gfc_trans_do(). */
|
code->cycle_label = cycle_label;
|
code->cycle_label = cycle_label;
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
|
|
/* Loop body. */
|
/* Loop body. */
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
/* Main loop body. */
|
/* Main loop body. */
|
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
|
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Label for cycle statements (if needed). */
|
/* Label for cycle statements (if needed). */
|
if (TREE_USED (cycle_label))
|
if (TREE_USED (cycle_label))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Check whether someone has modified the loop variable. */
|
/* Check whether someone has modified the loop variable. */
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
{
|
{
|
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
|
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
|
dovar, saved_dovar);
|
dovar, saved_dovar);
|
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
|
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
|
"Loop variable has been modified");
|
"Loop variable has been modified");
|
}
|
}
|
|
|
/* Exit the loop if there is an I/O result condition or error. */
|
/* Exit the loop if there is an I/O result condition or error. */
|
if (exit_cond)
|
if (exit_cond)
|
{
|
{
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
exit_cond, tmp,
|
exit_cond, tmp,
|
build_empty_stmt (loc));
|
build_empty_stmt (loc));
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Evaluate the loop condition. */
|
/* Evaluate the loop condition. */
|
cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
|
cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
|
to);
|
to);
|
cond = gfc_evaluate_now_loc (loc, cond, &body);
|
cond = gfc_evaluate_now_loc (loc, cond, &body);
|
|
|
/* Increment the loop variable. */
|
/* Increment the loop variable. */
|
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
|
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
|
gfc_add_modify_loc (loc, &body, dovar, tmp);
|
gfc_add_modify_loc (loc, &body, dovar, tmp);
|
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
|
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
|
|
|
/* The loop exit. */
|
/* The loop exit. */
|
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
|
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
|
TREE_USED (exit_label) = 1;
|
TREE_USED (exit_label) = 1;
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
cond, tmp, build_empty_stmt (loc));
|
cond, tmp, build_empty_stmt (loc));
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Finish the loop body. */
|
/* Finish the loop body. */
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
|
tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
|
|
|
/* Only execute the loop if the number of iterations is positive. */
|
/* Only execute the loop if the number of iterations is positive. */
|
if (tree_int_cst_sgn (step) > 0)
|
if (tree_int_cst_sgn (step) > 0)
|
cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
|
cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
|
to);
|
to);
|
else
|
else
|
cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
|
cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
|
to);
|
to);
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
|
build_empty_stmt (loc));
|
build_empty_stmt (loc));
|
gfc_add_expr_to_block (pblock, tmp);
|
gfc_add_expr_to_block (pblock, tmp);
|
|
|
/* Add the exit label. */
|
/* Add the exit label. */
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
gfc_add_expr_to_block (pblock, tmp);
|
gfc_add_expr_to_block (pblock, tmp);
|
|
|
return gfc_finish_block (pblock);
|
return gfc_finish_block (pblock);
|
}
|
}
|
|
|
/* Translate the DO construct. This obviously is one of the most
|
/* Translate the DO construct. This obviously is one of the most
|
important ones to get right with any compiler, but especially
|
important ones to get right with any compiler, but especially
|
so for Fortran.
|
so for Fortran.
|
|
|
We special case some loop forms as described in gfc_trans_simple_do.
|
We special case some loop forms as described in gfc_trans_simple_do.
|
For other cases we implement them with a separate loop count,
|
For other cases we implement them with a separate loop count,
|
as described in the standard.
|
as described in the standard.
|
|
|
We translate a do loop from:
|
We translate a do loop from:
|
|
|
DO dovar = from, to, step
|
DO dovar = from, to, step
|
body
|
body
|
END DO
|
END DO
|
|
|
to:
|
to:
|
|
|
[evaluate loop bounds and step]
|
[evaluate loop bounds and step]
|
empty = (step > 0 ? to < from : to > from);
|
empty = (step > 0 ? to < from : to > from);
|
countm1 = (to - from) / step;
|
countm1 = (to - from) / step;
|
dovar = from;
|
dovar = from;
|
if (empty) goto exit_label;
|
if (empty) goto exit_label;
|
for (;;)
|
for (;;)
|
{
|
{
|
body;
|
body;
|
cycle_label:
|
cycle_label:
|
dovar += step
|
dovar += step
|
if (countm1 ==0) goto exit_label;
|
if (countm1 ==0) goto exit_label;
|
countm1--;
|
countm1--;
|
}
|
}
|
exit_label:
|
exit_label:
|
|
|
countm1 is an unsigned integer. It is equal to the loop count minus one,
|
countm1 is an unsigned integer. It is equal to the loop count minus one,
|
because the loop count itself can overflow. */
|
because the loop count itself can overflow. */
|
|
|
tree
|
tree
|
gfc_trans_do (gfc_code * code, tree exit_cond)
|
gfc_trans_do (gfc_code * code, tree exit_cond)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree dovar;
|
tree dovar;
|
tree saved_dovar = NULL;
|
tree saved_dovar = NULL;
|
tree from;
|
tree from;
|
tree to;
|
tree to;
|
tree step;
|
tree step;
|
tree countm1;
|
tree countm1;
|
tree type;
|
tree type;
|
tree utype;
|
tree utype;
|
tree cond;
|
tree cond;
|
tree cycle_label;
|
tree cycle_label;
|
tree exit_label;
|
tree exit_label;
|
tree tmp;
|
tree tmp;
|
tree pos_step;
|
tree pos_step;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t body;
|
stmtblock_t body;
|
location_t loc;
|
location_t loc;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
loc = code->ext.iterator->start->where.lb->location;
|
loc = code->ext.iterator->start->where.lb->location;
|
|
|
/* Evaluate all the expressions in the iterator. */
|
/* Evaluate all the expressions in the iterator. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
|
gfc_conv_expr_lhs (&se, code->ext.iterator->var);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
dovar = se.expr;
|
dovar = se.expr;
|
type = TREE_TYPE (dovar);
|
type = TREE_TYPE (dovar);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->start);
|
gfc_conv_expr_val (&se, code->ext.iterator->start);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
from = gfc_evaluate_now (se.expr, &block);
|
from = gfc_evaluate_now (se.expr, &block);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->end);
|
gfc_conv_expr_val (&se, code->ext.iterator->end);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
to = gfc_evaluate_now (se.expr, &block);
|
to = gfc_evaluate_now (se.expr, &block);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->ext.iterator->step);
|
gfc_conv_expr_val (&se, code->ext.iterator->step);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
step = gfc_evaluate_now (se.expr, &block);
|
step = gfc_evaluate_now (se.expr, &block);
|
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
{
|
{
|
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
|
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
|
build_zero_cst (type));
|
build_zero_cst (type));
|
gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
|
gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
|
"DO step value is zero");
|
"DO step value is zero");
|
}
|
}
|
|
|
/* Special case simple loops. */
|
/* Special case simple loops. */
|
if (TREE_CODE (type) == INTEGER_TYPE
|
if (TREE_CODE (type) == INTEGER_TYPE
|
&& (integer_onep (step)
|
&& (integer_onep (step)
|
|| tree_int_cst_equal (step, integer_minus_one_node)))
|
|| tree_int_cst_equal (step, integer_minus_one_node)))
|
return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
|
return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
|
|
|
pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
|
pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
|
build_zero_cst (type));
|
build_zero_cst (type));
|
|
|
if (TREE_CODE (type) == INTEGER_TYPE)
|
if (TREE_CODE (type) == INTEGER_TYPE)
|
utype = unsigned_type_for (type);
|
utype = unsigned_type_for (type);
|
else
|
else
|
utype = unsigned_type_for (gfc_array_index_type);
|
utype = unsigned_type_for (gfc_array_index_type);
|
countm1 = gfc_create_var (utype, "countm1");
|
countm1 = gfc_create_var (utype, "countm1");
|
|
|
/* Cycle and exit statements are implemented with gotos. */
|
/* Cycle and exit statements are implemented with gotos. */
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
TREE_USED (exit_label) = 1;
|
TREE_USED (exit_label) = 1;
|
|
|
/* Put these labels where they can be found later. */
|
/* Put these labels where they can be found later. */
|
code->cycle_label = cycle_label;
|
code->cycle_label = cycle_label;
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
|
|
/* Initialize the DO variable: dovar = from. */
|
/* Initialize the DO variable: dovar = from. */
|
gfc_add_modify (&block, dovar, from);
|
gfc_add_modify (&block, dovar, from);
|
|
|
/* Save value for do-tinkering checking. */
|
/* Save value for do-tinkering checking. */
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
{
|
{
|
saved_dovar = gfc_create_var (type, ".saved_dovar");
|
saved_dovar = gfc_create_var (type, ".saved_dovar");
|
gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
|
gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
|
}
|
}
|
|
|
/* Initialize loop count and jump to exit label if the loop is empty.
|
/* Initialize loop count and jump to exit label if the loop is empty.
|
This code is executed before we enter the loop body. We generate:
|
This code is executed before we enter the loop body. We generate:
|
step_sign = sign(1,step);
|
step_sign = sign(1,step);
|
if (step > 0)
|
if (step > 0)
|
{
|
{
|
if (to < from)
|
if (to < from)
|
goto exit_label;
|
goto exit_label;
|
}
|
}
|
else
|
else
|
{
|
{
|
if (to > from)
|
if (to > from)
|
goto exit_label;
|
goto exit_label;
|
}
|
}
|
countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
|
countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
|
|
|
*/
|
*/
|
|
|
if (TREE_CODE (type) == INTEGER_TYPE)
|
if (TREE_CODE (type) == INTEGER_TYPE)
|
{
|
{
|
tree pos, neg, step_sign, to2, from2, step2;
|
tree pos, neg, step_sign, to2, from2, step2;
|
|
|
/* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
|
/* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
|
|
|
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
|
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
|
build_int_cst (TREE_TYPE (step), 0));
|
build_int_cst (TREE_TYPE (step), 0));
|
step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
|
step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp,
|
build_int_cst (type, -1),
|
build_int_cst (type, -1),
|
build_int_cst (type, 1));
|
build_int_cst (type, 1));
|
|
|
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
|
tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
|
pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
fold_build1_loc (loc, GOTO_EXPR, void_type_node,
|
fold_build1_loc (loc, GOTO_EXPR, void_type_node,
|
exit_label),
|
exit_label),
|
build_empty_stmt (loc));
|
build_empty_stmt (loc));
|
|
|
tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
|
tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to,
|
from);
|
from);
|
neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
fold_build1_loc (loc, GOTO_EXPR, void_type_node,
|
fold_build1_loc (loc, GOTO_EXPR, void_type_node,
|
exit_label),
|
exit_label),
|
build_empty_stmt (loc));
|
build_empty_stmt (loc));
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
pos_step, pos, neg);
|
pos_step, pos, neg);
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* Calculate the loop count. to-from can overflow, so
|
/* Calculate the loop count. to-from can overflow, so
|
we cast to unsigned. */
|
we cast to unsigned. */
|
|
|
to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
|
to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to);
|
from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
|
from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from);
|
step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
|
step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step);
|
step2 = fold_convert (utype, step2);
|
step2 = fold_convert (utype, step2);
|
tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
|
tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2);
|
tmp = fold_convert (utype, tmp);
|
tmp = fold_convert (utype, tmp);
|
tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
|
tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2);
|
tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
|
tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* TODO: We could use the same width as the real type.
|
/* TODO: We could use the same width as the real type.
|
This would probably cause more problems that it solves
|
This would probably cause more problems that it solves
|
when we implement "long double" types. */
|
when we implement "long double" types. */
|
|
|
tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
|
tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
|
tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
|
tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
|
tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
|
tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
|
gfc_add_modify (&block, countm1, tmp);
|
gfc_add_modify (&block, countm1, tmp);
|
|
|
/* We need a special check for empty loops:
|
/* We need a special check for empty loops:
|
empty = (step > 0 ? to < from : to > from); */
|
empty = (step > 0 ? to < from : to > from); */
|
tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
|
tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
|
fold_build2_loc (loc, LT_EXPR,
|
fold_build2_loc (loc, LT_EXPR,
|
boolean_type_node, to, from),
|
boolean_type_node, to, from),
|
fold_build2_loc (loc, GT_EXPR,
|
fold_build2_loc (loc, GT_EXPR,
|
boolean_type_node, to, from));
|
boolean_type_node, to, from));
|
/* If the loop is empty, go directly to the exit label. */
|
/* If the loop is empty, go directly to the exit label. */
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
|
build1_v (GOTO_EXPR, exit_label),
|
build1_v (GOTO_EXPR, exit_label),
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* Loop body. */
|
/* Loop body. */
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
/* Main loop body. */
|
/* Main loop body. */
|
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
|
tmp = gfc_trans_code_cond (code->block->next, exit_cond);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Label for cycle statements (if needed). */
|
/* Label for cycle statements (if needed). */
|
if (TREE_USED (cycle_label))
|
if (TREE_USED (cycle_label))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Check whether someone has modified the loop variable. */
|
/* Check whether someone has modified the loop variable. */
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
{
|
{
|
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
|
tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
|
saved_dovar);
|
saved_dovar);
|
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
|
gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
|
"Loop variable has been modified");
|
"Loop variable has been modified");
|
}
|
}
|
|
|
/* Exit the loop if there is an I/O result condition or error. */
|
/* Exit the loop if there is an I/O result condition or error. */
|
if (exit_cond)
|
if (exit_cond)
|
{
|
{
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
exit_cond, tmp,
|
exit_cond, tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Increment the loop variable. */
|
/* Increment the loop variable. */
|
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
|
tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
|
gfc_add_modify_loc (loc, &body, dovar, tmp);
|
gfc_add_modify_loc (loc, &body, dovar, tmp);
|
|
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
if (gfc_option.rtcheck & GFC_RTCHECK_DO)
|
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
|
gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
|
|
|
/* End with the loop condition. Loop until countm1 == 0. */
|
/* End with the loop condition. Loop until countm1 == 0. */
|
cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
|
cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1,
|
build_int_cst (utype, 0));
|
build_int_cst (utype, 0));
|
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
|
tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
|
cond, tmp, build_empty_stmt (loc));
|
cond, tmp, build_empty_stmt (loc));
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Decrement the loop count. */
|
/* Decrement the loop count. */
|
tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
|
tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
|
build_int_cst (utype, 1));
|
build_int_cst (utype, 1));
|
gfc_add_modify_loc (loc, &body, countm1, tmp);
|
gfc_add_modify_loc (loc, &body, countm1, tmp);
|
|
|
/* End of loop body. */
|
/* End of loop body. */
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
/* The for loop itself. */
|
/* The for loop itself. */
|
tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
|
tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* Add the exit label. */
|
/* Add the exit label. */
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the DO WHILE construct.
|
/* Translate the DO WHILE construct.
|
|
|
We translate
|
We translate
|
|
|
DO WHILE (cond)
|
DO WHILE (cond)
|
body
|
body
|
END DO
|
END DO
|
|
|
to:
|
to:
|
|
|
for ( ; ; )
|
for ( ; ; )
|
{
|
{
|
pre_cond;
|
pre_cond;
|
if (! cond) goto exit_label;
|
if (! cond) goto exit_label;
|
body;
|
body;
|
cycle_label:
|
cycle_label:
|
}
|
}
|
exit_label:
|
exit_label:
|
|
|
Because the evaluation of the exit condition `cond' may have side
|
Because the evaluation of the exit condition `cond' may have side
|
effects, we can't do much for empty loop bodies. The backend optimizers
|
effects, we can't do much for empty loop bodies. The backend optimizers
|
should be smart enough to eliminate any dead loops. */
|
should be smart enough to eliminate any dead loops. */
|
|
|
tree
|
tree
|
gfc_trans_do_while (gfc_code * code)
|
gfc_trans_do_while (gfc_code * code)
|
{
|
{
|
gfc_se cond;
|
gfc_se cond;
|
tree tmp;
|
tree tmp;
|
tree cycle_label;
|
tree cycle_label;
|
tree exit_label;
|
tree exit_label;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
/* Everything we build here is part of the loop body. */
|
/* Everything we build here is part of the loop body. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
/* Cycle and exit statements are implemented with gotos. */
|
/* Cycle and exit statements are implemented with gotos. */
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
exit_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(). */
|
/* Put the labels where they can be found later. See gfc_trans_do(). */
|
code->cycle_label = cycle_label;
|
code->cycle_label = cycle_label;
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
|
|
/* Create a GIMPLE version of the exit condition. */
|
/* Create a GIMPLE version of the exit condition. */
|
gfc_init_se (&cond, NULL);
|
gfc_init_se (&cond, NULL);
|
gfc_conv_expr_val (&cond, code->expr1);
|
gfc_conv_expr_val (&cond, code->expr1);
|
gfc_add_block_to_block (&block, &cond.pre);
|
gfc_add_block_to_block (&block, &cond.pre);
|
cond.expr = fold_build1_loc (code->expr1->where.lb->location,
|
cond.expr = fold_build1_loc (code->expr1->where.lb->location,
|
TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
|
TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
|
|
|
/* Build "IF (! cond) GOTO exit_label". */
|
/* Build "IF (! cond) GOTO exit_label". */
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
TREE_USED (exit_label) = 1;
|
TREE_USED (exit_label) = 1;
|
tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
|
tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
|
void_type_node, cond.expr, tmp,
|
void_type_node, cond.expr, tmp,
|
build_empty_stmt (code->expr1->where.lb->location));
|
build_empty_stmt (code->expr1->where.lb->location));
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* The main body of the loop. */
|
/* The main body of the loop. */
|
tmp = gfc_trans_code (code->block->next);
|
tmp = gfc_trans_code (code->block->next);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* Label for cycle statements (if needed). */
|
/* Label for cycle statements (if needed). */
|
if (TREE_USED (cycle_label))
|
if (TREE_USED (cycle_label))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* End of loop body. */
|
/* End of loop body. */
|
tmp = gfc_finish_block (&block);
|
tmp = gfc_finish_block (&block);
|
|
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
/* Build the loop. */
|
/* Build the loop. */
|
tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
|
tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
|
void_type_node, tmp);
|
void_type_node, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* Add the exit label. */
|
/* Add the exit label. */
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the SELECT CASE construct for INTEGER case expressions,
|
/* Translate the SELECT CASE construct for INTEGER case expressions,
|
without killing all potential optimizations. The problem is that
|
without killing all potential optimizations. The problem is that
|
Fortran allows unbounded cases, but the back-end does not, so we
|
Fortran allows unbounded cases, but the back-end does not, so we
|
need to intercept those before we enter the equivalent SWITCH_EXPR
|
need to intercept those before we enter the equivalent SWITCH_EXPR
|
we can build.
|
we can build.
|
|
|
For example, we translate this,
|
For example, we translate this,
|
|
|
SELECT CASE (expr)
|
SELECT CASE (expr)
|
CASE (:100,101,105:115)
|
CASE (:100,101,105:115)
|
block_1
|
block_1
|
CASE (190:199,200:)
|
CASE (190:199,200:)
|
block_2
|
block_2
|
CASE (300)
|
CASE (300)
|
block_3
|
block_3
|
CASE DEFAULT
|
CASE DEFAULT
|
block_4
|
block_4
|
END SELECT
|
END SELECT
|
|
|
to the GENERIC equivalent,
|
to the GENERIC equivalent,
|
|
|
switch (expr)
|
switch (expr)
|
{
|
{
|
case (minimum value for typeof(expr) ... 100:
|
case (minimum value for typeof(expr) ... 100:
|
case 101:
|
case 101:
|
case 105 ... 114:
|
case 105 ... 114:
|
block1:
|
block1:
|
goto end_label;
|
goto end_label;
|
|
|
case 200 ... (maximum value for typeof(expr):
|
case 200 ... (maximum value for typeof(expr):
|
case 190 ... 199:
|
case 190 ... 199:
|
block2;
|
block2;
|
goto end_label;
|
goto end_label;
|
|
|
case 300:
|
case 300:
|
block_3;
|
block_3;
|
goto end_label;
|
goto end_label;
|
|
|
default:
|
default:
|
block_4;
|
block_4;
|
goto end_label;
|
goto end_label;
|
}
|
}
|
|
|
end_label: */
|
end_label: */
|
|
|
static tree
|
static tree
|
gfc_trans_integer_select (gfc_code * code)
|
gfc_trans_integer_select (gfc_code * code)
|
{
|
{
|
gfc_code *c;
|
gfc_code *c;
|
gfc_case *cp;
|
gfc_case *cp;
|
tree end_label;
|
tree end_label;
|
tree tmp;
|
tree tmp;
|
gfc_se se;
|
gfc_se se;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t body;
|
stmtblock_t body;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
/* Calculate the switch expression. */
|
/* Calculate the switch expression. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
end_label = gfc_build_label_decl (NULL_TREE);
|
end_label = gfc_build_label_decl (NULL_TREE);
|
|
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
|
|
for (c = code->block; c; c = c->block)
|
for (c = code->block; c; c = c->block)
|
{
|
{
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
{
|
{
|
tree low, high;
|
tree low, high;
|
tree label;
|
tree label;
|
|
|
/* Assume it's the default case. */
|
/* Assume it's the default case. */
|
low = high = NULL_TREE;
|
low = high = NULL_TREE;
|
|
|
if (cp->low)
|
if (cp->low)
|
{
|
{
|
low = gfc_conv_mpz_to_tree (cp->low->value.integer,
|
low = gfc_conv_mpz_to_tree (cp->low->value.integer,
|
cp->low->ts.kind);
|
cp->low->ts.kind);
|
|
|
/* If there's only a lower bound, set the high bound to the
|
/* If there's only a lower bound, set the high bound to the
|
maximum value of the case expression. */
|
maximum value of the case expression. */
|
if (!cp->high)
|
if (!cp->high)
|
high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
|
high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
|
}
|
}
|
|
|
if (cp->high)
|
if (cp->high)
|
{
|
{
|
/* Three cases are possible here:
|
/* Three cases are possible here:
|
|
|
1) There is no lower bound, e.g. CASE (:N).
|
1) There is no lower bound, e.g. CASE (:N).
|
2) There is a lower bound .NE. high bound, that is
|
2) There is a lower bound .NE. high bound, that is
|
a case range, e.g. CASE (N:M) where M>N (we make
|
a case range, e.g. CASE (N:M) where M>N (we make
|
sure that M>N during type resolution).
|
sure that M>N during type resolution).
|
3) There is a lower bound, and it has the same value
|
3) There is a lower bound, and it has the same value
|
as the high bound, e.g. CASE (N:N). This is our
|
as the high bound, e.g. CASE (N:N). This is our
|
internal representation of CASE(N).
|
internal representation of CASE(N).
|
|
|
In the first and second case, we need to set a value for
|
In the first and second case, we need to set a value for
|
high. In the third 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
|
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
|
a NULL_TREE. We can't do that because we need to be able
|
to represent unbounded cases. */
|
to represent unbounded cases. */
|
|
|
if (!cp->low
|
if (!cp->low
|
|| (cp->low
|
|| (cp->low
|
&& mpz_cmp (cp->low->value.integer,
|
&& mpz_cmp (cp->low->value.integer,
|
cp->high->value.integer) != 0))
|
cp->high->value.integer) != 0))
|
high = gfc_conv_mpz_to_tree (cp->high->value.integer,
|
high = gfc_conv_mpz_to_tree (cp->high->value.integer,
|
cp->high->ts.kind);
|
cp->high->ts.kind);
|
|
|
/* Unbounded case. */
|
/* Unbounded case. */
|
if (!cp->low)
|
if (!cp->low)
|
low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
|
low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
|
}
|
}
|
|
|
/* Build a label. */
|
/* Build a label. */
|
label = gfc_build_label_decl (NULL_TREE);
|
label = gfc_build_label_decl (NULL_TREE);
|
|
|
/* Add this case label.
|
/* Add this case label.
|
Add parameter 'label', make it match GCC backend. */
|
Add parameter 'label', make it match GCC backend. */
|
tmp = build_case_label (low, high, label);
|
tmp = build_case_label (low, high, label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Add the statements for this case. */
|
/* Add the statements for this case. */
|
tmp = gfc_trans_code (c->next);
|
tmp = gfc_trans_code (c->next);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Break to the end of the construct. */
|
/* Break to the end of the construct. */
|
tmp = build1_v (GOTO_EXPR, end_label);
|
tmp = build1_v (GOTO_EXPR, end_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
|
tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
tmp = build1_v (LABEL_EXPR, end_label);
|
tmp = build1_v (LABEL_EXPR, end_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the SELECT CASE construct for LOGICAL case expressions.
|
/* Translate the SELECT CASE construct for LOGICAL case expressions.
|
|
|
There are only two cases possible here, even though the standard
|
There are only two cases possible here, even though the standard
|
does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
|
does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
|
.FALSE., and DEFAULT.
|
.FALSE., and DEFAULT.
|
|
|
We never generate more than two blocks here. Instead, we always
|
We never generate more than two blocks here. Instead, we always
|
try to eliminate the DEFAULT case. This way, we can translate this
|
try to eliminate the DEFAULT case. This way, we can translate this
|
kind of SELECT construct to a simple
|
kind of SELECT construct to a simple
|
|
|
if {} else {};
|
if {} else {};
|
|
|
expression in GENERIC. */
|
expression in GENERIC. */
|
|
|
static tree
|
static tree
|
gfc_trans_logical_select (gfc_code * code)
|
gfc_trans_logical_select (gfc_code * code)
|
{
|
{
|
gfc_code *c;
|
gfc_code *c;
|
gfc_code *t, *f, *d;
|
gfc_code *t, *f, *d;
|
gfc_case *cp;
|
gfc_case *cp;
|
gfc_se se;
|
gfc_se se;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
/* Assume we don't have any cases at all. */
|
/* Assume we don't have any cases at all. */
|
t = f = d = NULL;
|
t = f = d = NULL;
|
|
|
/* Now see which ones we actually do have. We can have at most two
|
/* Now see which ones we actually do have. We can have at most two
|
cases in a single case list: one for .TRUE. and one for .FALSE.
|
cases in a single case list: one for .TRUE. and one for .FALSE.
|
The default case is always separate. If the cases for .TRUE. and
|
The default case is always separate. If the cases for .TRUE. and
|
.FALSE. are in the same case list, the block for that case list
|
.FALSE. are in the same case list, the block for that case list
|
always executed, and we don't generate code a COND_EXPR. */
|
always executed, and we don't generate code a COND_EXPR. */
|
for (c = code->block; c; c = c->block)
|
for (c = code->block; c; c = c->block)
|
{
|
{
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
{
|
{
|
if (cp->low)
|
if (cp->low)
|
{
|
{
|
if (cp->low->value.logical == 0) /* .FALSE. */
|
if (cp->low->value.logical == 0) /* .FALSE. */
|
f = c;
|
f = c;
|
else /* if (cp->value.logical != 0), thus .TRUE. */
|
else /* if (cp->value.logical != 0), thus .TRUE. */
|
t = c;
|
t = c;
|
}
|
}
|
else
|
else
|
d = c;
|
d = c;
|
}
|
}
|
}
|
}
|
|
|
/* Start a new block. */
|
/* Start a new block. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
/* Calculate the switch expression. We always need to do this
|
/* Calculate the switch expression. We always need to do this
|
because it may have side effects. */
|
because it may have side effects. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
if (t == f && t != NULL)
|
if (t == f && t != NULL)
|
{
|
{
|
/* Cases for .TRUE. and .FALSE. are in the same block. Just
|
/* Cases for .TRUE. and .FALSE. are in the same block. Just
|
translate the code for these cases, append it to the current
|
translate the code for these cases, append it to the current
|
block. */
|
block. */
|
gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
|
gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
|
}
|
}
|
else
|
else
|
{
|
{
|
tree true_tree, false_tree, stmt;
|
tree true_tree, false_tree, stmt;
|
|
|
true_tree = build_empty_stmt (input_location);
|
true_tree = build_empty_stmt (input_location);
|
false_tree = build_empty_stmt (input_location);
|
false_tree = build_empty_stmt (input_location);
|
|
|
/* If we have a case for .TRUE. and for .FALSE., discard the default case.
|
/* If we have a case for .TRUE. and for .FALSE., discard the default case.
|
Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
|
Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
|
make the missing case the default case. */
|
make the missing case the default case. */
|
if (t != NULL && f != NULL)
|
if (t != NULL && f != NULL)
|
d = NULL;
|
d = NULL;
|
else if (d != NULL)
|
else if (d != NULL)
|
{
|
{
|
if (t == NULL)
|
if (t == NULL)
|
t = d;
|
t = d;
|
else
|
else
|
f = d;
|
f = d;
|
}
|
}
|
|
|
/* Translate the code for each of these blocks, and append it to
|
/* Translate the code for each of these blocks, and append it to
|
the current block. */
|
the current block. */
|
if (t != NULL)
|
if (t != NULL)
|
true_tree = gfc_trans_code (t->next);
|
true_tree = gfc_trans_code (t->next);
|
|
|
if (f != NULL)
|
if (f != NULL)
|
false_tree = gfc_trans_code (f->next);
|
false_tree = gfc_trans_code (f->next);
|
|
|
stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
se.expr, true_tree, false_tree);
|
se.expr, true_tree, false_tree);
|
gfc_add_expr_to_block (&block, stmt);
|
gfc_add_expr_to_block (&block, stmt);
|
}
|
}
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* The jump table types are stored in static variables to avoid
|
/* The jump table types are stored in static variables to avoid
|
constructing them from scratch every single time. */
|
constructing them from scratch every single time. */
|
static GTY(()) tree select_struct[2];
|
static GTY(()) tree select_struct[2];
|
|
|
/* Translate the SELECT CASE construct for CHARACTER case expressions.
|
/* Translate the SELECT CASE construct for CHARACTER case expressions.
|
Instead of generating compares and jumps, it is far simpler to
|
Instead of generating compares and jumps, it is far simpler to
|
generate a data structure describing the cases in order and call a
|
generate a data structure describing the cases in order and call a
|
library subroutine that locates the right case.
|
library subroutine that locates the right case.
|
This is particularly true because this is the only case where we
|
This is particularly true because this is the only case where we
|
might have to dispose of a temporary.
|
might have to dispose of a temporary.
|
The library subroutine returns a pointer to jump to or NULL if no
|
The library subroutine returns a pointer to jump to or NULL if no
|
branches are to be taken. */
|
branches are to be taken. */
|
|
|
static tree
|
static tree
|
gfc_trans_character_select (gfc_code *code)
|
gfc_trans_character_select (gfc_code *code)
|
{
|
{
|
tree init, end_label, tmp, type, case_num, label, fndecl;
|
tree init, end_label, tmp, type, case_num, label, fndecl;
|
stmtblock_t block, body;
|
stmtblock_t block, body;
|
gfc_case *cp, *d;
|
gfc_case *cp, *d;
|
gfc_code *c;
|
gfc_code *c;
|
gfc_se se, expr1se;
|
gfc_se se, expr1se;
|
int n, k;
|
int n, k;
|
VEC(constructor_elt,gc) *inits = NULL;
|
VEC(constructor_elt,gc) *inits = NULL;
|
|
|
tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
|
tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
|
|
|
/* The jump table types are stored in static variables to avoid
|
/* The jump table types are stored in static variables to avoid
|
constructing them from scratch every single time. */
|
constructing them from scratch every single time. */
|
static tree ss_string1[2], ss_string1_len[2];
|
static tree ss_string1[2], ss_string1_len[2];
|
static tree ss_string2[2], ss_string2_len[2];
|
static tree ss_string2[2], ss_string2_len[2];
|
static tree ss_target[2];
|
static tree ss_target[2];
|
|
|
cp = code->block->ext.block.case_list;
|
cp = code->block->ext.block.case_list;
|
while (cp->left != NULL)
|
while (cp->left != NULL)
|
cp = cp->left;
|
cp = cp->left;
|
|
|
/* Generate the body */
|
/* Generate the body */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_se (&expr1se, NULL);
|
gfc_init_se (&expr1se, NULL);
|
gfc_conv_expr_reference (&expr1se, code->expr1);
|
gfc_conv_expr_reference (&expr1se, code->expr1);
|
|
|
gfc_add_block_to_block (&block, &expr1se.pre);
|
gfc_add_block_to_block (&block, &expr1se.pre);
|
|
|
end_label = gfc_build_label_decl (NULL_TREE);
|
end_label = gfc_build_label_decl (NULL_TREE);
|
|
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
|
|
/* Attempt to optimize length 1 selects. */
|
/* Attempt to optimize length 1 selects. */
|
if (integer_onep (expr1se.string_length))
|
if (integer_onep (expr1se.string_length))
|
{
|
{
|
for (d = cp; d; d = d->right)
|
for (d = cp; d; d = d->right)
|
{
|
{
|
int i;
|
int i;
|
if (d->low)
|
if (d->low)
|
{
|
{
|
gcc_assert (d->low->expr_type == EXPR_CONSTANT
|
gcc_assert (d->low->expr_type == EXPR_CONSTANT
|
&& d->low->ts.type == BT_CHARACTER);
|
&& d->low->ts.type == BT_CHARACTER);
|
if (d->low->value.character.length > 1)
|
if (d->low->value.character.length > 1)
|
{
|
{
|
for (i = 1; i < d->low->value.character.length; i++)
|
for (i = 1; i < d->low->value.character.length; i++)
|
if (d->low->value.character.string[i] != ' ')
|
if (d->low->value.character.string[i] != ' ')
|
break;
|
break;
|
if (i != d->low->value.character.length)
|
if (i != d->low->value.character.length)
|
{
|
{
|
if (optimize && d->high && i == 1)
|
if (optimize && d->high && i == 1)
|
{
|
{
|
gcc_assert (d->high->expr_type == EXPR_CONSTANT
|
gcc_assert (d->high->expr_type == EXPR_CONSTANT
|
&& d->high->ts.type == BT_CHARACTER);
|
&& d->high->ts.type == BT_CHARACTER);
|
if (d->high->value.character.length > 1
|
if (d->high->value.character.length > 1
|
&& (d->low->value.character.string[0]
|
&& (d->low->value.character.string[0]
|
== d->high->value.character.string[0])
|
== d->high->value.character.string[0])
|
&& d->high->value.character.string[1] != ' '
|
&& d->high->value.character.string[1] != ' '
|
&& ((d->low->value.character.string[1] < ' ')
|
&& ((d->low->value.character.string[1] < ' ')
|
== (d->high->value.character.string[1]
|
== (d->high->value.character.string[1]
|
< ' ')))
|
< ' ')))
|
continue;
|
continue;
|
}
|
}
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
if (d->high)
|
if (d->high)
|
{
|
{
|
gcc_assert (d->high->expr_type == EXPR_CONSTANT
|
gcc_assert (d->high->expr_type == EXPR_CONSTANT
|
&& d->high->ts.type == BT_CHARACTER);
|
&& d->high->ts.type == BT_CHARACTER);
|
if (d->high->value.character.length > 1)
|
if (d->high->value.character.length > 1)
|
{
|
{
|
for (i = 1; i < d->high->value.character.length; i++)
|
for (i = 1; i < d->high->value.character.length; i++)
|
if (d->high->value.character.string[i] != ' ')
|
if (d->high->value.character.string[i] != ' ')
|
break;
|
break;
|
if (i != d->high->value.character.length)
|
if (i != d->high->value.character.length)
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
if (d == NULL)
|
if (d == NULL)
|
{
|
{
|
tree ctype = gfc_get_char_type (code->expr1->ts.kind);
|
tree ctype = gfc_get_char_type (code->expr1->ts.kind);
|
|
|
for (c = code->block; c; c = c->block)
|
for (c = code->block; c; c = c->block)
|
{
|
{
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
for (cp = c->ext.block.case_list; cp; cp = cp->next)
|
{
|
{
|
tree low, high;
|
tree low, high;
|
tree label;
|
tree label;
|
gfc_char_t r;
|
gfc_char_t r;
|
|
|
/* Assume it's the default case. */
|
/* Assume it's the default case. */
|
low = high = NULL_TREE;
|
low = high = NULL_TREE;
|
|
|
if (cp->low)
|
if (cp->low)
|
{
|
{
|
/* CASE ('ab') or CASE ('ab':'az') will never match
|
/* CASE ('ab') or CASE ('ab':'az') will never match
|
any length 1 character. */
|
any length 1 character. */
|
if (cp->low->value.character.length > 1
|
if (cp->low->value.character.length > 1
|
&& cp->low->value.character.string[1] != ' ')
|
&& cp->low->value.character.string[1] != ' ')
|
continue;
|
continue;
|
|
|
if (cp->low->value.character.length > 0)
|
if (cp->low->value.character.length > 0)
|
r = cp->low->value.character.string[0];
|
r = cp->low->value.character.string[0];
|
else
|
else
|
r = ' ';
|
r = ' ';
|
low = build_int_cst (ctype, r);
|
low = build_int_cst (ctype, r);
|
|
|
/* If there's only a lower bound, set the high bound
|
/* If there's only a lower bound, set the high bound
|
to the maximum value of the case expression. */
|
to the maximum value of the case expression. */
|
if (!cp->high)
|
if (!cp->high)
|
high = TYPE_MAX_VALUE (ctype);
|
high = TYPE_MAX_VALUE (ctype);
|
}
|
}
|
|
|
if (cp->high)
|
if (cp->high)
|
{
|
{
|
if (!cp->low
|
if (!cp->low
|
|| (cp->low->value.character.string[0]
|
|| (cp->low->value.character.string[0]
|
!= cp->high->value.character.string[0]))
|
!= cp->high->value.character.string[0]))
|
{
|
{
|
if (cp->high->value.character.length > 0)
|
if (cp->high->value.character.length > 0)
|
r = cp->high->value.character.string[0];
|
r = cp->high->value.character.string[0];
|
else
|
else
|
r = ' ';
|
r = ' ';
|
high = build_int_cst (ctype, r);
|
high = build_int_cst (ctype, r);
|
}
|
}
|
|
|
/* Unbounded case. */
|
/* Unbounded case. */
|
if (!cp->low)
|
if (!cp->low)
|
low = TYPE_MIN_VALUE (ctype);
|
low = TYPE_MIN_VALUE (ctype);
|
}
|
}
|
|
|
/* Build a label. */
|
/* Build a label. */
|
label = gfc_build_label_decl (NULL_TREE);
|
label = gfc_build_label_decl (NULL_TREE);
|
|
|
/* Add this case label.
|
/* Add this case label.
|
Add parameter 'label', make it match GCC backend. */
|
Add parameter 'label', make it match GCC backend. */
|
tmp = build_case_label (low, high, label);
|
tmp = build_case_label (low, high, label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Add the statements for this case. */
|
/* Add the statements for this case. */
|
tmp = gfc_trans_code (c->next);
|
tmp = gfc_trans_code (c->next);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Break to the end of the construct. */
|
/* Break to the end of the construct. */
|
tmp = build1_v (GOTO_EXPR, end_label);
|
tmp = build1_v (GOTO_EXPR, end_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
tmp = gfc_string_to_single_character (expr1se.string_length,
|
tmp = gfc_string_to_single_character (expr1se.string_length,
|
expr1se.expr,
|
expr1se.expr,
|
code->expr1->ts.kind);
|
code->expr1->ts.kind);
|
case_num = gfc_create_var (ctype, "case_num");
|
case_num = gfc_create_var (ctype, "case_num");
|
gfc_add_modify (&block, case_num, tmp);
|
gfc_add_modify (&block, case_num, tmp);
|
|
|
gfc_add_block_to_block (&block, &expr1se.post);
|
gfc_add_block_to_block (&block, &expr1se.post);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
|
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
tmp = build1_v (LABEL_EXPR, end_label);
|
tmp = build1_v (LABEL_EXPR, end_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
}
|
}
|
|
|
if (code->expr1->ts.kind == 1)
|
if (code->expr1->ts.kind == 1)
|
k = 0;
|
k = 0;
|
else if (code->expr1->ts.kind == 4)
|
else if (code->expr1->ts.kind == 4)
|
k = 1;
|
k = 1;
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
if (select_struct[k] == NULL)
|
if (select_struct[k] == NULL)
|
{
|
{
|
tree *chain = NULL;
|
tree *chain = NULL;
|
select_struct[k] = make_node (RECORD_TYPE);
|
select_struct[k] = make_node (RECORD_TYPE);
|
|
|
if (code->expr1->ts.kind == 1)
|
if (code->expr1->ts.kind == 1)
|
TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
|
TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
|
else if (code->expr1->ts.kind == 4)
|
else if (code->expr1->ts.kind == 4)
|
TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
|
TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
#undef ADD_FIELD
|
#undef ADD_FIELD
|
#define ADD_FIELD(NAME, TYPE) \
|
#define ADD_FIELD(NAME, TYPE) \
|
ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
|
ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
|
get_identifier (stringize(NAME)), \
|
get_identifier (stringize(NAME)), \
|
TYPE, \
|
TYPE, \
|
&chain)
|
&chain)
|
|
|
ADD_FIELD (string1, pchartype);
|
ADD_FIELD (string1, pchartype);
|
ADD_FIELD (string1_len, gfc_charlen_type_node);
|
ADD_FIELD (string1_len, gfc_charlen_type_node);
|
|
|
ADD_FIELD (string2, pchartype);
|
ADD_FIELD (string2, pchartype);
|
ADD_FIELD (string2_len, gfc_charlen_type_node);
|
ADD_FIELD (string2_len, gfc_charlen_type_node);
|
|
|
ADD_FIELD (target, integer_type_node);
|
ADD_FIELD (target, integer_type_node);
|
#undef ADD_FIELD
|
#undef ADD_FIELD
|
|
|
gfc_finish_type (select_struct[k]);
|
gfc_finish_type (select_struct[k]);
|
}
|
}
|
|
|
n = 0;
|
n = 0;
|
for (d = cp; d; d = d->right)
|
for (d = cp; d; d = d->right)
|
d->n = n++;
|
d->n = n++;
|
|
|
for (c = code->block; c; c = c->block)
|
for (c = code->block; c; c = c->block)
|
{
|
{
|
for (d = c->ext.block.case_list; d; d = d->next)
|
for (d = c->ext.block.case_list; d; d = d->next)
|
{
|
{
|
label = gfc_build_label_decl (NULL_TREE);
|
label = gfc_build_label_decl (NULL_TREE);
|
tmp = build_case_label ((d->low == NULL && d->high == NULL)
|
tmp = build_case_label ((d->low == NULL && d->high == NULL)
|
? NULL
|
? NULL
|
: build_int_cst (integer_type_node, d->n),
|
: build_int_cst (integer_type_node, d->n),
|
NULL, label);
|
NULL, label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
tmp = gfc_trans_code (c->next);
|
tmp = gfc_trans_code (c->next);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
tmp = build1_v (GOTO_EXPR, end_label);
|
tmp = build1_v (GOTO_EXPR, end_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
/* Generate the structure describing the branches */
|
/* Generate the structure describing the branches */
|
for (d = cp; d; d = d->right)
|
for (d = cp; d; d = d->right)
|
{
|
{
|
VEC(constructor_elt,gc) *node = NULL;
|
VEC(constructor_elt,gc) *node = NULL;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
if (d->low == NULL)
|
if (d->low == NULL)
|
{
|
{
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_conv_expr_reference (&se, d->low);
|
gfc_conv_expr_reference (&se, d->low);
|
|
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
|
}
|
}
|
|
|
if (d->high == NULL)
|
if (d->high == NULL)
|
{
|
{
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_reference (&se, d->high);
|
gfc_conv_expr_reference (&se, d->high);
|
|
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
|
CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
|
}
|
}
|
|
|
CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
|
CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
|
build_int_cst (integer_type_node, d->n));
|
build_int_cst (integer_type_node, d->n));
|
|
|
tmp = build_constructor (select_struct[k], node);
|
tmp = build_constructor (select_struct[k], node);
|
CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
|
CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
|
}
|
}
|
|
|
type = build_array_type (select_struct[k],
|
type = build_array_type (select_struct[k],
|
build_index_type (size_int (n-1)));
|
build_index_type (size_int (n-1)));
|
|
|
init = build_constructor (type, inits);
|
init = build_constructor (type, inits);
|
TREE_CONSTANT (init) = 1;
|
TREE_CONSTANT (init) = 1;
|
TREE_STATIC (init) = 1;
|
TREE_STATIC (init) = 1;
|
/* Create a static variable to hold the jump table. */
|
/* Create a static variable to hold the jump table. */
|
tmp = gfc_create_var (type, "jumptable");
|
tmp = gfc_create_var (type, "jumptable");
|
TREE_CONSTANT (tmp) = 1;
|
TREE_CONSTANT (tmp) = 1;
|
TREE_STATIC (tmp) = 1;
|
TREE_STATIC (tmp) = 1;
|
TREE_READONLY (tmp) = 1;
|
TREE_READONLY (tmp) = 1;
|
DECL_INITIAL (tmp) = init;
|
DECL_INITIAL (tmp) = init;
|
init = tmp;
|
init = tmp;
|
|
|
/* Build the library call */
|
/* Build the library call */
|
init = gfc_build_addr_expr (pvoid_type_node, init);
|
init = gfc_build_addr_expr (pvoid_type_node, init);
|
|
|
if (code->expr1->ts.kind == 1)
|
if (code->expr1->ts.kind == 1)
|
fndecl = gfor_fndecl_select_string;
|
fndecl = gfor_fndecl_select_string;
|
else if (code->expr1->ts.kind == 4)
|
else if (code->expr1->ts.kind == 4)
|
fndecl = gfor_fndecl_select_string_char4;
|
fndecl = gfor_fndecl_select_string_char4;
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
fndecl, 4, init,
|
fndecl, 4, init,
|
build_int_cst (gfc_charlen_type_node, n),
|
build_int_cst (gfc_charlen_type_node, n),
|
expr1se.expr, expr1se.string_length);
|
expr1se.expr, expr1se.string_length);
|
case_num = gfc_create_var (integer_type_node, "case_num");
|
case_num = gfc_create_var (integer_type_node, "case_num");
|
gfc_add_modify (&block, case_num, tmp);
|
gfc_add_modify (&block, case_num, tmp);
|
|
|
gfc_add_block_to_block (&block, &expr1se.post);
|
gfc_add_block_to_block (&block, &expr1se.post);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
|
tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
tmp = build1_v (LABEL_EXPR, end_label);
|
tmp = build1_v (LABEL_EXPR, end_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the three variants of the SELECT CASE construct.
|
/* Translate the three variants of the SELECT CASE construct.
|
|
|
SELECT CASEs with INTEGER case expressions can be translated to an
|
SELECT CASEs with INTEGER case expressions can be translated to an
|
equivalent GENERIC switch statement, and for LOGICAL case
|
equivalent GENERIC switch statement, and for LOGICAL case
|
expressions we build one or two if-else compares.
|
expressions we build one or two if-else compares.
|
|
|
SELECT CASEs with CHARACTER case expressions are a whole different
|
SELECT CASEs with CHARACTER case expressions are a whole different
|
story, because they don't exist in GENERIC. So we sort them and
|
story, because they don't exist in GENERIC. So we sort them and
|
do a binary search at runtime.
|
do a binary search at runtime.
|
|
|
Fortran has no BREAK statement, and it does not allow jumps from
|
Fortran has no BREAK statement, and it does not allow jumps from
|
one case block to another. That makes things a lot easier for
|
one case block to another. That makes things a lot easier for
|
the optimizers. */
|
the optimizers. */
|
|
|
tree
|
tree
|
gfc_trans_select (gfc_code * code)
|
gfc_trans_select (gfc_code * code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
tree body;
|
tree body;
|
tree exit_label;
|
tree exit_label;
|
|
|
gcc_assert (code && code->expr1);
|
gcc_assert (code && code->expr1);
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
|
|
/* Build the exit label and hang it in. */
|
/* Build the exit label and hang it in. */
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
code->exit_label = exit_label;
|
code->exit_label = exit_label;
|
|
|
/* Empty SELECT constructs are legal. */
|
/* Empty SELECT constructs are legal. */
|
if (code->block == NULL)
|
if (code->block == NULL)
|
body = build_empty_stmt (input_location);
|
body = build_empty_stmt (input_location);
|
|
|
/* Select the correct translation function. */
|
/* Select the correct translation function. */
|
else
|
else
|
switch (code->expr1->ts.type)
|
switch (code->expr1->ts.type)
|
{
|
{
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
body = gfc_trans_logical_select (code);
|
body = gfc_trans_logical_select (code);
|
break;
|
break;
|
|
|
case BT_INTEGER:
|
case BT_INTEGER:
|
body = gfc_trans_integer_select (code);
|
body = gfc_trans_integer_select (code);
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
body = gfc_trans_character_select (code);
|
body = gfc_trans_character_select (code);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
|
gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
|
/* Not reached */
|
/* Not reached */
|
}
|
}
|
|
|
/* Build everything together. */
|
/* Build everything together. */
|
gfc_add_expr_to_block (&block, body);
|
gfc_add_expr_to_block (&block, body);
|
gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
|
gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Traversal function to substitute a replacement symtree if the symbol
|
/* Traversal function to substitute a replacement symtree if the symbol
|
in the expression is the same as that passed. f == 2 signals that
|
in the expression is the same as that passed. f == 2 signals that
|
that variable itself is not to be checked - only the references.
|
that variable itself is not to be checked - only the references.
|
This group of functions is used when the variable expression in a
|
This group of functions is used when the variable expression in a
|
FORALL assignment has internal references. For example:
|
FORALL assignment has internal references. For example:
|
FORALL (i = 1:4) p(p(i)) = i
|
FORALL (i = 1:4) p(p(i)) = i
|
The only recourse here is to store a copy of 'p' for the index
|
The only recourse here is to store a copy of 'p' for the index
|
expression. */
|
expression. */
|
|
|
static gfc_symtree *new_symtree;
|
static gfc_symtree *new_symtree;
|
static gfc_symtree *old_symtree;
|
static gfc_symtree *old_symtree;
|
|
|
static bool
|
static bool
|
forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
|
forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
|
{
|
{
|
if (expr->expr_type != EXPR_VARIABLE)
|
if (expr->expr_type != EXPR_VARIABLE)
|
return false;
|
return false;
|
|
|
if (*f == 2)
|
if (*f == 2)
|
*f = 1;
|
*f = 1;
|
else if (expr->symtree->n.sym == sym)
|
else if (expr->symtree->n.sym == sym)
|
expr->symtree = new_symtree;
|
expr->symtree = new_symtree;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
static void
|
static void
|
forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
|
forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
|
{
|
{
|
gfc_traverse_expr (e, sym, forall_replace, f);
|
gfc_traverse_expr (e, sym, forall_replace, f);
|
}
|
}
|
|
|
static bool
|
static bool
|
forall_restore (gfc_expr *expr,
|
forall_restore (gfc_expr *expr,
|
gfc_symbol *sym ATTRIBUTE_UNUSED,
|
gfc_symbol *sym ATTRIBUTE_UNUSED,
|
int *f ATTRIBUTE_UNUSED)
|
int *f ATTRIBUTE_UNUSED)
|
{
|
{
|
if (expr->expr_type != EXPR_VARIABLE)
|
if (expr->expr_type != EXPR_VARIABLE)
|
return false;
|
return false;
|
|
|
if (expr->symtree == new_symtree)
|
if (expr->symtree == new_symtree)
|
expr->symtree = old_symtree;
|
expr->symtree = old_symtree;
|
|
|
return false;
|
return false;
|
}
|
}
|
|
|
static void
|
static void
|
forall_restore_symtree (gfc_expr *e)
|
forall_restore_symtree (gfc_expr *e)
|
{
|
{
|
gfc_traverse_expr (e, NULL, forall_restore, 0);
|
gfc_traverse_expr (e, NULL, forall_restore, 0);
|
}
|
}
|
|
|
static void
|
static void
|
forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
|
forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
|
{
|
{
|
gfc_se tse;
|
gfc_se tse;
|
gfc_se rse;
|
gfc_se rse;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_symbol *new_sym;
|
gfc_symbol *new_sym;
|
gfc_symbol *old_sym;
|
gfc_symbol *old_sym;
|
gfc_symtree *root;
|
gfc_symtree *root;
|
tree tmp;
|
tree tmp;
|
|
|
/* Build a copy of the lvalue. */
|
/* Build a copy of the lvalue. */
|
old_symtree = c->expr1->symtree;
|
old_symtree = c->expr1->symtree;
|
old_sym = old_symtree->n.sym;
|
old_sym = old_symtree->n.sym;
|
e = gfc_lval_expr_from_sym (old_sym);
|
e = gfc_lval_expr_from_sym (old_sym);
|
if (old_sym->attr.dimension)
|
if (old_sym->attr.dimension)
|
{
|
{
|
gfc_init_se (&tse, NULL);
|
gfc_init_se (&tse, NULL);
|
gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
|
gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
|
gfc_add_block_to_block (pre, &tse.pre);
|
gfc_add_block_to_block (pre, &tse.pre);
|
gfc_add_block_to_block (post, &tse.post);
|
gfc_add_block_to_block (post, &tse.post);
|
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
|
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
|
|
|
if (e->ts.type != BT_CHARACTER)
|
if (e->ts.type != BT_CHARACTER)
|
{
|
{
|
/* Use the variable offset for the temporary. */
|
/* Use the variable offset for the temporary. */
|
tmp = gfc_conv_array_offset (old_sym->backend_decl);
|
tmp = gfc_conv_array_offset (old_sym->backend_decl);
|
gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
|
gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_init_se (&tse, NULL);
|
gfc_init_se (&tse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_conv_expr (&rse, e);
|
gfc_conv_expr (&rse, e);
|
if (e->ts.type == BT_CHARACTER)
|
if (e->ts.type == BT_CHARACTER)
|
{
|
{
|
tse.string_length = rse.string_length;
|
tse.string_length = rse.string_length;
|
tmp = gfc_get_character_type_len (gfc_default_character_kind,
|
tmp = gfc_get_character_type_len (gfc_default_character_kind,
|
tse.string_length);
|
tse.string_length);
|
tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
|
tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
|
rse.string_length);
|
rse.string_length);
|
gfc_add_block_to_block (pre, &tse.pre);
|
gfc_add_block_to_block (pre, &tse.pre);
|
gfc_add_block_to_block (post, &tse.post);
|
gfc_add_block_to_block (post, &tse.post);
|
}
|
}
|
else
|
else
|
{
|
{
|
tmp = gfc_typenode_for_spec (&e->ts);
|
tmp = gfc_typenode_for_spec (&e->ts);
|
tse.expr = gfc_create_var (tmp, "temp");
|
tse.expr = gfc_create_var (tmp, "temp");
|
}
|
}
|
|
|
tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
|
tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
|
e->expr_type == EXPR_VARIABLE, true);
|
e->expr_type == EXPR_VARIABLE, true);
|
gfc_add_expr_to_block (pre, tmp);
|
gfc_add_expr_to_block (pre, tmp);
|
}
|
}
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
/* Create a new symbol to represent the lvalue. */
|
/* Create a new symbol to represent the lvalue. */
|
new_sym = gfc_new_symbol (old_sym->name, NULL);
|
new_sym = gfc_new_symbol (old_sym->name, NULL);
|
new_sym->ts = old_sym->ts;
|
new_sym->ts = old_sym->ts;
|
new_sym->attr.referenced = 1;
|
new_sym->attr.referenced = 1;
|
new_sym->attr.temporary = 1;
|
new_sym->attr.temporary = 1;
|
new_sym->attr.dimension = old_sym->attr.dimension;
|
new_sym->attr.dimension = old_sym->attr.dimension;
|
new_sym->attr.flavor = old_sym->attr.flavor;
|
new_sym->attr.flavor = old_sym->attr.flavor;
|
|
|
/* Use the temporary as the backend_decl. */
|
/* Use the temporary as the backend_decl. */
|
new_sym->backend_decl = tse.expr;
|
new_sym->backend_decl = tse.expr;
|
|
|
/* Create a fake symtree for it. */
|
/* Create a fake symtree for it. */
|
root = NULL;
|
root = NULL;
|
new_symtree = gfc_new_symtree (&root, old_sym->name);
|
new_symtree = gfc_new_symtree (&root, old_sym->name);
|
new_symtree->n.sym = new_sym;
|
new_symtree->n.sym = new_sym;
|
gcc_assert (new_symtree == root);
|
gcc_assert (new_symtree == root);
|
|
|
/* Go through the expression reference replacing the old_symtree
|
/* Go through the expression reference replacing the old_symtree
|
with the new. */
|
with the new. */
|
forall_replace_symtree (c->expr1, old_sym, 2);
|
forall_replace_symtree (c->expr1, old_sym, 2);
|
|
|
/* Now we have made this temporary, we might as well use it for
|
/* Now we have made this temporary, we might as well use it for
|
the right hand side. */
|
the right hand side. */
|
forall_replace_symtree (c->expr2, old_sym, 1);
|
forall_replace_symtree (c->expr2, old_sym, 1);
|
}
|
}
|
|
|
|
|
/* Handles dependencies in forall assignments. */
|
/* Handles dependencies in forall assignments. */
|
static int
|
static int
|
check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
|
check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
|
{
|
{
|
gfc_ref *lref;
|
gfc_ref *lref;
|
gfc_ref *rref;
|
gfc_ref *rref;
|
int need_temp;
|
int need_temp;
|
gfc_symbol *lsym;
|
gfc_symbol *lsym;
|
|
|
lsym = c->expr1->symtree->n.sym;
|
lsym = c->expr1->symtree->n.sym;
|
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
|
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
|
|
|
/* Now check for dependencies within the 'variable'
|
/* Now check for dependencies within the 'variable'
|
expression itself. These are treated by making a complete
|
expression itself. These are treated by making a complete
|
copy of variable and changing all the references to it
|
copy of variable and changing all the references to it
|
point to the copy instead. Note that the shallow copy of
|
point to the copy instead. Note that the shallow copy of
|
the variable will not suffice for derived types with
|
the variable will not suffice for derived types with
|
pointer components. We therefore leave these to their
|
pointer components. We therefore leave these to their
|
own devices. */
|
own devices. */
|
if (lsym->ts.type == BT_DERIVED
|
if (lsym->ts.type == BT_DERIVED
|
&& lsym->ts.u.derived->attr.pointer_comp)
|
&& lsym->ts.u.derived->attr.pointer_comp)
|
return need_temp;
|
return need_temp;
|
|
|
new_symtree = NULL;
|
new_symtree = NULL;
|
if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
|
if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
|
{
|
{
|
forall_make_variable_temp (c, pre, post);
|
forall_make_variable_temp (c, pre, post);
|
need_temp = 0;
|
need_temp = 0;
|
}
|
}
|
|
|
/* Substrings with dependencies are treated in the same
|
/* Substrings with dependencies are treated in the same
|
way. */
|
way. */
|
if (c->expr1->ts.type == BT_CHARACTER
|
if (c->expr1->ts.type == BT_CHARACTER
|
&& c->expr1->ref
|
&& c->expr1->ref
|
&& c->expr2->expr_type == EXPR_VARIABLE
|
&& c->expr2->expr_type == EXPR_VARIABLE
|
&& lsym == c->expr2->symtree->n.sym)
|
&& lsym == c->expr2->symtree->n.sym)
|
{
|
{
|
for (lref = c->expr1->ref; lref; lref = lref->next)
|
for (lref = c->expr1->ref; lref; lref = lref->next)
|
if (lref->type == REF_SUBSTRING)
|
if (lref->type == REF_SUBSTRING)
|
break;
|
break;
|
for (rref = c->expr2->ref; rref; rref = rref->next)
|
for (rref = c->expr2->ref; rref; rref = rref->next)
|
if (rref->type == REF_SUBSTRING)
|
if (rref->type == REF_SUBSTRING)
|
break;
|
break;
|
|
|
if (rref && lref
|
if (rref && lref
|
&& gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
|
&& gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
|
{
|
{
|
forall_make_variable_temp (c, pre, post);
|
forall_make_variable_temp (c, pre, post);
|
need_temp = 0;
|
need_temp = 0;
|
}
|
}
|
}
|
}
|
return need_temp;
|
return need_temp;
|
}
|
}
|
|
|
|
|
static void
|
static void
|
cleanup_forall_symtrees (gfc_code *c)
|
cleanup_forall_symtrees (gfc_code *c)
|
{
|
{
|
forall_restore_symtree (c->expr1);
|
forall_restore_symtree (c->expr1);
|
forall_restore_symtree (c->expr2);
|
forall_restore_symtree (c->expr2);
|
free (new_symtree->n.sym);
|
free (new_symtree->n.sym);
|
free (new_symtree);
|
free (new_symtree);
|
}
|
}
|
|
|
|
|
/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
|
/* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
|
is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
|
is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
|
indicates whether we should generate code to test the FORALLs mask
|
indicates whether we should generate code to test the FORALLs mask
|
array. OUTER is the loop header to be used for initializing mask
|
array. OUTER is the loop header to be used for initializing mask
|
indices.
|
indices.
|
|
|
The generated loop format is:
|
The generated loop format is:
|
count = (end - start + step) / step
|
count = (end - start + step) / step
|
loopvar = start
|
loopvar = start
|
while (1)
|
while (1)
|
{
|
{
|
if (count <=0 )
|
if (count <=0 )
|
goto end_of_loop
|
goto end_of_loop
|
<body>
|
<body>
|
loopvar += step
|
loopvar += step
|
count --
|
count --
|
}
|
}
|
end_of_loop: */
|
end_of_loop: */
|
|
|
static tree
|
static tree
|
gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
|
gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
|
int mask_flag, stmtblock_t *outer)
|
int mask_flag, stmtblock_t *outer)
|
{
|
{
|
int n, nvar;
|
int n, nvar;
|
tree tmp;
|
tree tmp;
|
tree cond;
|
tree cond;
|
stmtblock_t block;
|
stmtblock_t block;
|
tree exit_label;
|
tree exit_label;
|
tree count;
|
tree count;
|
tree var, start, end, step;
|
tree var, start, end, step;
|
iter_info *iter;
|
iter_info *iter;
|
|
|
/* Initialize the mask index outside the FORALL nest. */
|
/* Initialize the mask index outside the FORALL nest. */
|
if (mask_flag && forall_tmp->mask)
|
if (mask_flag && forall_tmp->mask)
|
gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
|
gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
|
|
|
iter = forall_tmp->this_loop;
|
iter = forall_tmp->this_loop;
|
nvar = forall_tmp->nvar;
|
nvar = forall_tmp->nvar;
|
for (n = 0; n < nvar; n++)
|
for (n = 0; n < nvar; n++)
|
{
|
{
|
var = iter->var;
|
var = iter->var;
|
start = iter->start;
|
start = iter->start;
|
end = iter->end;
|
end = iter->end;
|
step = iter->step;
|
step = iter->step;
|
|
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
exit_label = gfc_build_label_decl (NULL_TREE);
|
TREE_USED (exit_label) = 1;
|
TREE_USED (exit_label) = 1;
|
|
|
/* The loop counter. */
|
/* The loop counter. */
|
count = gfc_create_var (TREE_TYPE (var), "count");
|
count = gfc_create_var (TREE_TYPE (var), "count");
|
|
|
/* The body of the loop. */
|
/* The body of the loop. */
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
|
|
/* The exit condition. */
|
/* The exit condition. */
|
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
|
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
|
count, build_int_cst (TREE_TYPE (count), 0));
|
count, build_int_cst (TREE_TYPE (count), 0));
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = build1_v (GOTO_EXPR, exit_label);
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
cond, tmp, build_empty_stmt (input_location));
|
cond, tmp, build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* The main loop body. */
|
/* The main loop body. */
|
gfc_add_expr_to_block (&block, body);
|
gfc_add_expr_to_block (&block, body);
|
|
|
/* Increment the loop variable. */
|
/* Increment the loop variable. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
|
step);
|
step);
|
gfc_add_modify (&block, var, tmp);
|
gfc_add_modify (&block, var, tmp);
|
|
|
/* Advance to the next mask element. Only do this for the
|
/* Advance to the next mask element. Only do this for the
|
innermost loop. */
|
innermost loop. */
|
if (n == 0 && mask_flag && forall_tmp->mask)
|
if (n == 0 && mask_flag && forall_tmp->mask)
|
{
|
{
|
tree maskindex = forall_tmp->maskindex;
|
tree maskindex = forall_tmp->maskindex;
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
maskindex, gfc_index_one_node);
|
maskindex, gfc_index_one_node);
|
gfc_add_modify (&block, maskindex, tmp);
|
gfc_add_modify (&block, maskindex, tmp);
|
}
|
}
|
|
|
/* Decrement the loop counter. */
|
/* Decrement the loop counter. */
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
|
build_int_cst (TREE_TYPE (var), 1));
|
build_int_cst (TREE_TYPE (var), 1));
|
gfc_add_modify (&block, count, tmp);
|
gfc_add_modify (&block, count, tmp);
|
|
|
body = gfc_finish_block (&block);
|
body = gfc_finish_block (&block);
|
|
|
/* Loop var initialization. */
|
/* Loop var initialization. */
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
gfc_add_modify (&block, var, start);
|
gfc_add_modify (&block, var, start);
|
|
|
|
|
/* Initialize the loop counter. */
|
/* Initialize the loop counter. */
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
|
start);
|
start);
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
|
tmp);
|
tmp);
|
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
|
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
|
tmp, step);
|
tmp, step);
|
gfc_add_modify (&block, count, tmp);
|
gfc_add_modify (&block, count, tmp);
|
|
|
/* The loop expression. */
|
/* The loop expression. */
|
tmp = build1_v (LOOP_EXPR, body);
|
tmp = build1_v (LOOP_EXPR, body);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
/* The exit label. */
|
/* The exit label. */
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
tmp = build1_v (LABEL_EXPR, exit_label);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
body = gfc_finish_block (&block);
|
body = gfc_finish_block (&block);
|
iter = iter->next;
|
iter = iter->next;
|
}
|
}
|
return body;
|
return body;
|
}
|
}
|
|
|
|
|
/* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
|
/* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
|
is nonzero, the body is controlled by all masks in the forall nest.
|
is nonzero, the body is controlled by all masks in the forall nest.
|
Otherwise, the innermost loop is not controlled by it's mask. This
|
Otherwise, the innermost loop is not controlled by it's mask. This
|
is used for initializing that mask. */
|
is used for initializing that mask. */
|
|
|
static tree
|
static tree
|
gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
|
gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
|
int mask_flag)
|
int mask_flag)
|
{
|
{
|
tree tmp;
|
tree tmp;
|
stmtblock_t header;
|
stmtblock_t header;
|
forall_info *forall_tmp;
|
forall_info *forall_tmp;
|
tree mask, maskindex;
|
tree mask, maskindex;
|
|
|
gfc_start_block (&header);
|
gfc_start_block (&header);
|
|
|
forall_tmp = nested_forall_info;
|
forall_tmp = nested_forall_info;
|
while (forall_tmp != NULL)
|
while (forall_tmp != NULL)
|
{
|
{
|
/* Generate body with masks' control. */
|
/* Generate body with masks' control. */
|
if (mask_flag)
|
if (mask_flag)
|
{
|
{
|
mask = forall_tmp->mask;
|
mask = forall_tmp->mask;
|
maskindex = forall_tmp->maskindex;
|
maskindex = forall_tmp->maskindex;
|
|
|
/* If a mask was specified make the assignment conditional. */
|
/* If a mask was specified make the assignment conditional. */
|
if (mask)
|
if (mask)
|
{
|
{
|
tmp = gfc_build_array_ref (mask, maskindex, NULL);
|
tmp = gfc_build_array_ref (mask, maskindex, NULL);
|
body = build3_v (COND_EXPR, tmp, body,
|
body = build3_v (COND_EXPR, tmp, body,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
}
|
}
|
}
|
}
|
body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
|
body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
|
forall_tmp = forall_tmp->prev_nest;
|
forall_tmp = forall_tmp->prev_nest;
|
mask_flag = 1;
|
mask_flag = 1;
|
}
|
}
|
|
|
gfc_add_expr_to_block (&header, body);
|
gfc_add_expr_to_block (&header, body);
|
return gfc_finish_block (&header);
|
return gfc_finish_block (&header);
|
}
|
}
|
|
|
|
|
/* Allocate data for holding a temporary array. Returns either a local
|
/* Allocate data for holding a temporary array. Returns either a local
|
temporary array or a pointer variable. */
|
temporary array or a pointer variable. */
|
|
|
static tree
|
static tree
|
gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
|
gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
|
tree elem_type)
|
tree elem_type)
|
{
|
{
|
tree tmpvar;
|
tree tmpvar;
|
tree type;
|
tree type;
|
tree tmp;
|
tree tmp;
|
|
|
if (INTEGER_CST_P (size))
|
if (INTEGER_CST_P (size))
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
|
size, gfc_index_one_node);
|
size, gfc_index_one_node);
|
else
|
else
|
tmp = NULL_TREE;
|
tmp = NULL_TREE;
|
|
|
type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
|
type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
|
type = build_array_type (elem_type, type);
|
type = build_array_type (elem_type, type);
|
if (gfc_can_put_var_on_stack (bytesize))
|
if (gfc_can_put_var_on_stack (bytesize))
|
{
|
{
|
gcc_assert (INTEGER_CST_P (size));
|
gcc_assert (INTEGER_CST_P (size));
|
tmpvar = gfc_create_var (type, "temp");
|
tmpvar = gfc_create_var (type, "temp");
|
*pdata = NULL_TREE;
|
*pdata = NULL_TREE;
|
}
|
}
|
else
|
else
|
{
|
{
|
tmpvar = gfc_create_var (build_pointer_type (type), "temp");
|
tmpvar = gfc_create_var (build_pointer_type (type), "temp");
|
*pdata = convert (pvoid_type_node, tmpvar);
|
*pdata = convert (pvoid_type_node, tmpvar);
|
|
|
tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
|
tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
|
gfc_add_modify (pblock, tmpvar, tmp);
|
gfc_add_modify (pblock, tmpvar, tmp);
|
}
|
}
|
return tmpvar;
|
return tmpvar;
|
}
|
}
|
|
|
|
|
/* Generate codes to copy the temporary to the actual lhs. */
|
/* Generate codes to copy the temporary to the actual lhs. */
|
|
|
static tree
|
static tree
|
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
|
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
|
tree count1, tree wheremask, bool invert)
|
tree count1, tree wheremask, bool invert)
|
{
|
{
|
gfc_ss *lss;
|
gfc_ss *lss;
|
gfc_se lse, rse;
|
gfc_se lse, rse;
|
stmtblock_t block, body;
|
stmtblock_t block, body;
|
gfc_loopinfo loop1;
|
gfc_loopinfo loop1;
|
tree tmp;
|
tree tmp;
|
tree wheremaskexpr;
|
tree wheremaskexpr;
|
|
|
/* Walk the lhs. */
|
/* Walk the lhs. */
|
lss = gfc_walk_expr (expr);
|
lss = gfc_walk_expr (expr);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
|
|
/* Translate the expression. */
|
/* Translate the expression. */
|
gfc_conv_expr (&lse, expr);
|
gfc_conv_expr (&lse, expr);
|
|
|
/* Form the expression for the temporary. */
|
/* Form the expression for the temporary. */
|
tmp = gfc_build_array_ref (tmp1, count1, NULL);
|
tmp = gfc_build_array_ref (tmp1, count1, NULL);
|
|
|
/* Use the scalar assignment as is. */
|
/* Use the scalar assignment as is. */
|
gfc_add_block_to_block (&block, &lse.pre);
|
gfc_add_block_to_block (&block, &lse.pre);
|
gfc_add_modify (&block, lse.expr, tmp);
|
gfc_add_modify (&block, lse.expr, tmp);
|
gfc_add_block_to_block (&block, &lse.post);
|
gfc_add_block_to_block (&block, &lse.post);
|
|
|
/* Increment the count1. */
|
/* Increment the count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&block, count1, tmp);
|
gfc_add_modify (&block, count1, tmp);
|
|
|
tmp = gfc_finish_block (&block);
|
tmp = gfc_finish_block (&block);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_init_loopinfo (&loop1);
|
gfc_init_loopinfo (&loop1);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
|
|
/* Associate the lss with the loop. */
|
/* Associate the lss with the loop. */
|
gfc_add_ss_to_loop (&loop1, lss);
|
gfc_add_ss_to_loop (&loop1, lss);
|
|
|
/* Calculate the bounds of the scalarization. */
|
/* Calculate the bounds of the scalarization. */
|
gfc_conv_ss_startstride (&loop1);
|
gfc_conv_ss_startstride (&loop1);
|
/* Setup the scalarizing loops. */
|
/* Setup the scalarizing loops. */
|
gfc_conv_loop_setup (&loop1, &expr->where);
|
gfc_conv_loop_setup (&loop1, &expr->where);
|
|
|
gfc_mark_ss_chain_used (lss, 1);
|
gfc_mark_ss_chain_used (lss, 1);
|
|
|
/* Start the scalarized loop body. */
|
/* Start the scalarized loop body. */
|
gfc_start_scalarized_body (&loop1, &body);
|
gfc_start_scalarized_body (&loop1, &body);
|
|
|
/* Setup the gfc_se structures. */
|
/* Setup the gfc_se structures. */
|
gfc_copy_loopinfo_to_se (&lse, &loop1);
|
gfc_copy_loopinfo_to_se (&lse, &loop1);
|
lse.ss = lss;
|
lse.ss = lss;
|
|
|
/* Form the expression of the temporary. */
|
/* Form the expression of the temporary. */
|
if (lss != gfc_ss_terminator)
|
if (lss != gfc_ss_terminator)
|
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
/* Translate expr. */
|
/* Translate expr. */
|
gfc_conv_expr (&lse, expr);
|
gfc_conv_expr (&lse, expr);
|
|
|
/* Use the scalar assignment. */
|
/* Use the scalar assignment. */
|
rse.string_length = lse.string_length;
|
rse.string_length = lse.string_length;
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
|
|
|
/* Form the mask expression according to the mask tree list. */
|
/* Form the mask expression according to the mask tree list. */
|
if (wheremask)
|
if (wheremask)
|
{
|
{
|
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
|
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
|
if (invert)
|
if (invert)
|
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
TREE_TYPE (wheremaskexpr),
|
TREE_TYPE (wheremaskexpr),
|
wheremaskexpr);
|
wheremaskexpr);
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
wheremaskexpr, tmp,
|
wheremaskexpr, tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
}
|
}
|
|
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Increment count1. */
|
/* Increment count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&body, count1, tmp);
|
gfc_add_modify (&body, count1, tmp);
|
|
|
/* Increment count3. */
|
/* Increment count3. */
|
if (count3)
|
if (count3)
|
{
|
{
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, count3,
|
gfc_array_index_type, count3,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
gfc_add_modify (&body, count3, tmp);
|
gfc_add_modify (&body, count3, tmp);
|
}
|
}
|
|
|
/* Generate the copying loops. */
|
/* Generate the copying loops. */
|
gfc_trans_scalarizing_loops (&loop1, &body);
|
gfc_trans_scalarizing_loops (&loop1, &body);
|
gfc_add_block_to_block (&block, &loop1.pre);
|
gfc_add_block_to_block (&block, &loop1.pre);
|
gfc_add_block_to_block (&block, &loop1.post);
|
gfc_add_block_to_block (&block, &loop1.post);
|
gfc_cleanup_loop (&loop1);
|
gfc_cleanup_loop (&loop1);
|
|
|
tmp = gfc_finish_block (&block);
|
tmp = gfc_finish_block (&block);
|
}
|
}
|
return tmp;
|
return tmp;
|
}
|
}
|
|
|
|
|
/* Generate codes to copy rhs to the temporary. TMP1 is the address of
|
/* 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(),
|
temporary, LSS and RSS are formed in function compute_inner_temp_size(),
|
and should not be freed. WHEREMASK is the conditional execution mask
|
and should not be freed. WHEREMASK is the conditional execution mask
|
whose sense may be inverted by INVERT. */
|
whose sense may be inverted by INVERT. */
|
|
|
static tree
|
static tree
|
generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
|
generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
|
tree count1, gfc_ss *lss, gfc_ss *rss,
|
tree count1, gfc_ss *lss, gfc_ss *rss,
|
tree wheremask, bool invert)
|
tree wheremask, bool invert)
|
{
|
{
|
stmtblock_t block, body1;
|
stmtblock_t block, body1;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
gfc_se lse;
|
gfc_se lse;
|
gfc_se rse;
|
gfc_se rse;
|
tree tmp;
|
tree tmp;
|
tree wheremaskexpr;
|
tree wheremaskexpr;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
gfc_init_block (&body1);
|
gfc_init_block (&body1);
|
gfc_conv_expr (&rse, expr2);
|
gfc_conv_expr (&rse, expr2);
|
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Initialize the loop. */
|
/* Initialize the loop. */
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* We may need LSS to determine the shape of the expression. */
|
/* We may need LSS to determine the shape of the expression. */
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, rss);
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
|
|
gfc_mark_ss_chain_used (rss, 1);
|
gfc_mark_ss_chain_used (rss, 1);
|
/* Start the loop body. */
|
/* Start the loop body. */
|
gfc_start_scalarized_body (&loop, &body1);
|
gfc_start_scalarized_body (&loop, &body1);
|
|
|
/* Translate the expression. */
|
/* Translate the expression. */
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
rse.ss = rss;
|
rse.ss = rss;
|
gfc_conv_expr (&rse, expr2);
|
gfc_conv_expr (&rse, expr2);
|
|
|
/* Form the expression of the temporary. */
|
/* Form the expression of the temporary. */
|
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
|
}
|
}
|
|
|
/* Use the scalar assignment. */
|
/* Use the scalar assignment. */
|
lse.string_length = rse.string_length;
|
lse.string_length = rse.string_length;
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
|
expr2->expr_type == EXPR_VARIABLE, true);
|
expr2->expr_type == EXPR_VARIABLE, true);
|
|
|
/* Form the mask expression according to the mask tree list. */
|
/* Form the mask expression according to the mask tree list. */
|
if (wheremask)
|
if (wheremask)
|
{
|
{
|
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
|
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
|
if (invert)
|
if (invert)
|
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
TREE_TYPE (wheremaskexpr),
|
TREE_TYPE (wheremaskexpr),
|
wheremaskexpr);
|
wheremaskexpr);
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
wheremaskexpr, tmp,
|
wheremaskexpr, tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
}
|
}
|
|
|
gfc_add_expr_to_block (&body1, tmp);
|
gfc_add_expr_to_block (&body1, tmp);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
gfc_add_block_to_block (&block, &body1);
|
gfc_add_block_to_block (&block, &body1);
|
|
|
/* Increment count1. */
|
/* Increment count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&block, count1, tmp);
|
gfc_add_modify (&block, count1, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Increment count1. */
|
/* Increment count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&body1, count1, tmp);
|
gfc_add_modify (&body1, count1, tmp);
|
|
|
/* Increment count3. */
|
/* Increment count3. */
|
if (count3)
|
if (count3)
|
{
|
{
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type,
|
gfc_array_index_type,
|
count3, gfc_index_one_node);
|
count3, gfc_index_one_node);
|
gfc_add_modify (&body1, count3, tmp);
|
gfc_add_modify (&body1, count3, tmp);
|
}
|
}
|
|
|
/* Generate the copying loops. */
|
/* Generate the copying loops. */
|
gfc_trans_scalarizing_loops (&loop, &body1);
|
gfc_trans_scalarizing_loops (&loop, &body1);
|
|
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_add_block_to_block (&block, &loop.post);
|
|
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
/* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
|
/* 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. */
|
}
|
}
|
|
|
tmp = gfc_finish_block (&block);
|
tmp = gfc_finish_block (&block);
|
return tmp;
|
return tmp;
|
}
|
}
|
|
|
|
|
/* Calculate the size of temporary needed in the assignment inside forall.
|
/* Calculate the size of temporary needed in the assignment inside forall.
|
LSS and RSS are filled in this function. */
|
LSS and RSS are filled in this function. */
|
|
|
static tree
|
static tree
|
compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
|
compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
|
stmtblock_t * pblock,
|
stmtblock_t * pblock,
|
gfc_ss **lss, gfc_ss **rss)
|
gfc_ss **lss, gfc_ss **rss)
|
{
|
{
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
tree size;
|
tree size;
|
int i;
|
int i;
|
int save_flag;
|
int save_flag;
|
tree tmp;
|
tree tmp;
|
|
|
*lss = gfc_walk_expr (expr1);
|
*lss = gfc_walk_expr (expr1);
|
*rss = NULL;
|
*rss = NULL;
|
|
|
size = gfc_index_one_node;
|
size = gfc_index_one_node;
|
if (*lss != gfc_ss_terminator)
|
if (*lss != gfc_ss_terminator)
|
{
|
{
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* Walk the RHS of the expression. */
|
/* Walk the RHS of the expression. */
|
*rss = gfc_walk_expr (expr2);
|
*rss = gfc_walk_expr (expr2);
|
if (*rss == gfc_ss_terminator)
|
if (*rss == gfc_ss_terminator)
|
/* The rhs is scalar. Add a ss for the expression. */
|
/* The rhs is scalar. Add a ss for the expression. */
|
*rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
|
*rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
|
|
|
/* Associate the SS with the loop. */
|
/* Associate the SS with the loop. */
|
gfc_add_ss_to_loop (&loop, *lss);
|
gfc_add_ss_to_loop (&loop, *lss);
|
/* We don't actually need to add the rhs at this point, but it might
|
/* We don't actually need to add the rhs at this point, but it might
|
make guessing the loop bounds a bit easier. */
|
make guessing the loop bounds a bit easier. */
|
gfc_add_ss_to_loop (&loop, *rss);
|
gfc_add_ss_to_loop (&loop, *rss);
|
|
|
/* We only want the shape of the expression, not rest of the junk
|
/* We only want the shape of the expression, not rest of the junk
|
generated by the scalarizer. */
|
generated by the scalarizer. */
|
loop.array_parameter = 1;
|
loop.array_parameter = 1;
|
|
|
/* Calculate the bounds of the scalarization. */
|
/* Calculate the bounds of the scalarization. */
|
save_flag = gfc_option.rtcheck;
|
save_flag = gfc_option.rtcheck;
|
gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
|
gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_option.rtcheck = save_flag;
|
gfc_option.rtcheck = save_flag;
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
|
|
/* Figure out how many elements we need. */
|
/* Figure out how many elements we need. */
|
for (i = 0; i < loop.dimen; i++)
|
for (i = 0; i < loop.dimen; i++)
|
{
|
{
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
tmp = fold_build2_loc (input_location, MINUS_EXPR,
|
gfc_array_index_type,
|
gfc_array_index_type,
|
gfc_index_one_node, loop.from[i]);
|
gfc_index_one_node, loop.from[i]);
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, tmp, loop.to[i]);
|
gfc_array_index_type, tmp, loop.to[i]);
|
size = fold_build2_loc (input_location, MULT_EXPR,
|
size = fold_build2_loc (input_location, MULT_EXPR,
|
gfc_array_index_type, size, tmp);
|
gfc_array_index_type, size, tmp);
|
}
|
}
|
gfc_add_block_to_block (pblock, &loop.pre);
|
gfc_add_block_to_block (pblock, &loop.pre);
|
size = gfc_evaluate_now (size, pblock);
|
size = gfc_evaluate_now (size, pblock);
|
gfc_add_block_to_block (pblock, &loop.post);
|
gfc_add_block_to_block (pblock, &loop.post);
|
|
|
/* TODO: write a function that cleans up a loopinfo without freeing
|
/* TODO: write a function that cleans up a loopinfo without freeing
|
the SS chains. Currently a NOP. */
|
the SS chains. Currently a NOP. */
|
}
|
}
|
|
|
return size;
|
return size;
|
}
|
}
|
|
|
|
|
/* Calculate the overall iterator number of the nested forall construct.
|
/* Calculate the overall iterator number of the nested forall construct.
|
This routine actually calculates the number of times the body of the
|
This routine actually calculates the number of times the body of the
|
nested forall specified by NESTED_FORALL_INFO is executed and multiplies
|
nested forall specified by NESTED_FORALL_INFO is executed and multiplies
|
that by the expression INNER_SIZE. The BLOCK argument specifies the
|
that by the expression INNER_SIZE. The BLOCK argument specifies the
|
block in which to calculate the result, and the optional INNER_SIZE_BODY
|
block in which to calculate the result, and the optional INNER_SIZE_BODY
|
argument contains any statements that need to executed (inside the loop)
|
argument contains any statements that need to executed (inside the loop)
|
to initialize or calculate INNER_SIZE. */
|
to initialize or calculate INNER_SIZE. */
|
|
|
static tree
|
static tree
|
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
|
compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
|
stmtblock_t *inner_size_body, stmtblock_t *block)
|
stmtblock_t *inner_size_body, stmtblock_t *block)
|
{
|
{
|
forall_info *forall_tmp = nested_forall_info;
|
forall_info *forall_tmp = nested_forall_info;
|
tree tmp, number;
|
tree tmp, number;
|
stmtblock_t body;
|
stmtblock_t body;
|
|
|
/* We can eliminate the innermost unconditional loops with constant
|
/* We can eliminate the innermost unconditional loops with constant
|
array bounds. */
|
array bounds. */
|
if (INTEGER_CST_P (inner_size))
|
if (INTEGER_CST_P (inner_size))
|
{
|
{
|
while (forall_tmp
|
while (forall_tmp
|
&& !forall_tmp->mask
|
&& !forall_tmp->mask
|
&& INTEGER_CST_P (forall_tmp->size))
|
&& INTEGER_CST_P (forall_tmp->size))
|
{
|
{
|
inner_size = fold_build2_loc (input_location, MULT_EXPR,
|
inner_size = fold_build2_loc (input_location, MULT_EXPR,
|
gfc_array_index_type,
|
gfc_array_index_type,
|
inner_size, forall_tmp->size);
|
inner_size, forall_tmp->size);
|
forall_tmp = forall_tmp->prev_nest;
|
forall_tmp = forall_tmp->prev_nest;
|
}
|
}
|
|
|
/* If there are no loops left, we have our constant result. */
|
/* If there are no loops left, we have our constant result. */
|
if (!forall_tmp)
|
if (!forall_tmp)
|
return inner_size;
|
return inner_size;
|
}
|
}
|
|
|
/* Otherwise, create a temporary variable to compute the result. */
|
/* Otherwise, create a temporary variable to compute the result. */
|
number = gfc_create_var (gfc_array_index_type, "num");
|
number = gfc_create_var (gfc_array_index_type, "num");
|
gfc_add_modify (block, number, gfc_index_zero_node);
|
gfc_add_modify (block, number, gfc_index_zero_node);
|
|
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
if (inner_size_body)
|
if (inner_size_body)
|
gfc_add_block_to_block (&body, inner_size_body);
|
gfc_add_block_to_block (&body, inner_size_body);
|
if (forall_tmp)
|
if (forall_tmp)
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, number, inner_size);
|
gfc_array_index_type, number, inner_size);
|
else
|
else
|
tmp = inner_size;
|
tmp = inner_size;
|
gfc_add_modify (&body, number, tmp);
|
gfc_add_modify (&body, number, tmp);
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
/* Generate loops. */
|
/* Generate loops. */
|
if (forall_tmp != NULL)
|
if (forall_tmp != NULL)
|
tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
|
|
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
return number;
|
return number;
|
}
|
}
|
|
|
|
|
/* Allocate temporary for forall construct. SIZE is the size of temporary
|
/* Allocate temporary for forall construct. SIZE is the size of temporary
|
needed. PTEMP1 is returned for space free. */
|
needed. PTEMP1 is returned for space free. */
|
|
|
static tree
|
static tree
|
allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
|
allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
|
tree * ptemp1)
|
tree * ptemp1)
|
{
|
{
|
tree bytesize;
|
tree bytesize;
|
tree unit;
|
tree unit;
|
tree tmp;
|
tree tmp;
|
|
|
unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
|
unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
|
if (!integer_onep (unit))
|
if (!integer_onep (unit))
|
bytesize = fold_build2_loc (input_location, MULT_EXPR,
|
bytesize = fold_build2_loc (input_location, MULT_EXPR,
|
gfc_array_index_type, size, unit);
|
gfc_array_index_type, size, unit);
|
else
|
else
|
bytesize = size;
|
bytesize = size;
|
|
|
*ptemp1 = NULL;
|
*ptemp1 = NULL;
|
tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
|
tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
|
|
|
if (*ptemp1)
|
if (*ptemp1)
|
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
return tmp;
|
return tmp;
|
}
|
}
|
|
|
|
|
/* Allocate temporary for forall construct according to the information in
|
/* Allocate temporary for forall construct according to the information in
|
nested_forall_info. INNER_SIZE is the size of temporary needed in the
|
nested_forall_info. INNER_SIZE is the size of temporary needed in the
|
assignment inside forall. PTEMP1 is returned for space free. */
|
assignment inside forall. PTEMP1 is returned for space free. */
|
|
|
static tree
|
static tree
|
allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
|
allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
|
tree inner_size, stmtblock_t * inner_size_body,
|
tree inner_size, stmtblock_t * inner_size_body,
|
stmtblock_t * block, tree * ptemp1)
|
stmtblock_t * block, tree * ptemp1)
|
{
|
{
|
tree size;
|
tree size;
|
|
|
/* Calculate the total size of temporary needed in forall construct. */
|
/* Calculate the total size of temporary needed in forall construct. */
|
size = compute_overall_iter_number (nested_forall_info, inner_size,
|
size = compute_overall_iter_number (nested_forall_info, inner_size,
|
inner_size_body, block);
|
inner_size_body, block);
|
|
|
return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
|
return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
|
}
|
}
|
|
|
|
|
/* Handle assignments inside forall which need temporary.
|
/* Handle assignments inside forall which need temporary.
|
|
|
forall (i=start:end:stride; maskexpr)
|
forall (i=start:end:stride; maskexpr)
|
e<i> = f<i>
|
e<i> = f<i>
|
end forall
|
end forall
|
(where e,f<i> are arbitrary expressions possibly involving i
|
(where e,f<i> are arbitrary expressions possibly involving i
|
and there is a dependency between e<i> and f<i>)
|
and there is a dependency between e<i> and f<i>)
|
Translates to:
|
Translates to:
|
masktmp(:) = maskexpr(:)
|
masktmp(:) = maskexpr(:)
|
|
|
maskindex = 0;
|
maskindex = 0;
|
count1 = 0;
|
count1 = 0;
|
num = 0;
|
num = 0;
|
for (i = start; i <= end; i += stride)
|
for (i = start; i <= end; i += stride)
|
num += SIZE (f<i>)
|
num += SIZE (f<i>)
|
count1 = 0;
|
count1 = 0;
|
ALLOCATE (tmp(num))
|
ALLOCATE (tmp(num))
|
for (i = start; i <= end; i += stride)
|
for (i = start; i <= end; i += stride)
|
{
|
{
|
if (masktmp[maskindex++])
|
if (masktmp[maskindex++])
|
tmp[count1++] = f<i>
|
tmp[count1++] = f<i>
|
}
|
}
|
maskindex = 0;
|
maskindex = 0;
|
count1 = 0;
|
count1 = 0;
|
for (i = start; i <= end; i += stride)
|
for (i = start; i <= end; i += stride)
|
{
|
{
|
if (masktmp[maskindex++])
|
if (masktmp[maskindex++])
|
e<i> = tmp[count1++]
|
e<i> = tmp[count1++]
|
}
|
}
|
DEALLOCATE (tmp)
|
DEALLOCATE (tmp)
|
*/
|
*/
|
static void
|
static void
|
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
|
gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
|
tree wheremask, bool invert,
|
tree wheremask, bool invert,
|
forall_info * nested_forall_info,
|
forall_info * nested_forall_info,
|
stmtblock_t * block)
|
stmtblock_t * block)
|
{
|
{
|
tree type;
|
tree type;
|
tree inner_size;
|
tree inner_size;
|
gfc_ss *lss, *rss;
|
gfc_ss *lss, *rss;
|
tree count, count1;
|
tree count, count1;
|
tree tmp, tmp1;
|
tree tmp, tmp1;
|
tree ptemp1;
|
tree ptemp1;
|
stmtblock_t inner_size_body;
|
stmtblock_t inner_size_body;
|
|
|
/* Create vars. count1 is the current iterator number of the nested
|
/* Create vars. count1 is the current iterator number of the nested
|
forall. */
|
forall. */
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
|
|
/* Count is the wheremask index. */
|
/* Count is the wheremask index. */
|
if (wheremask)
|
if (wheremask)
|
{
|
{
|
count = gfc_create_var (gfc_array_index_type, "count");
|
count = gfc_create_var (gfc_array_index_type, "count");
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
}
|
}
|
else
|
else
|
count = NULL;
|
count = NULL;
|
|
|
/* Initialize count1. */
|
/* Initialize count1. */
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
|
|
/* Calculate the size of temporary needed in the assignment. Return loop, lss
|
/* 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(). */
|
and rss which are used in function generate_loop_for_rhs_to_temp(). */
|
gfc_init_block (&inner_size_body);
|
gfc_init_block (&inner_size_body);
|
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
|
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
|
&lss, &rss);
|
&lss, &rss);
|
|
|
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
|
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
|
if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
|
if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
|
{
|
{
|
if (!expr1->ts.u.cl->backend_decl)
|
if (!expr1->ts.u.cl->backend_decl)
|
{
|
{
|
gfc_se tse;
|
gfc_se tse;
|
gfc_init_se (&tse, NULL);
|
gfc_init_se (&tse, NULL);
|
gfc_conv_expr (&tse, expr1->ts.u.cl->length);
|
gfc_conv_expr (&tse, expr1->ts.u.cl->length);
|
expr1->ts.u.cl->backend_decl = tse.expr;
|
expr1->ts.u.cl->backend_decl = tse.expr;
|
}
|
}
|
type = gfc_get_character_type_len (gfc_default_character_kind,
|
type = gfc_get_character_type_len (gfc_default_character_kind,
|
expr1->ts.u.cl->backend_decl);
|
expr1->ts.u.cl->backend_decl);
|
}
|
}
|
else
|
else
|
type = gfc_typenode_for_spec (&expr1->ts);
|
type = gfc_typenode_for_spec (&expr1->ts);
|
|
|
/* Allocate temporary for nested forall construct according to the
|
/* Allocate temporary for nested forall construct according to the
|
information in nested_forall_info and inner_size. */
|
information in nested_forall_info and inner_size. */
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
|
&inner_size_body, block, &ptemp1);
|
&inner_size_body, block, &ptemp1);
|
|
|
/* Generate codes to copy rhs to the temporary . */
|
/* Generate codes to copy rhs to the temporary . */
|
tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
|
tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
|
wheremask, invert);
|
wheremask, invert);
|
|
|
/* Generate body and loops according to the information in
|
/* Generate body and loops according to the information in
|
nested_forall_info. */
|
nested_forall_info. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
/* Reset count1. */
|
/* Reset count1. */
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
|
|
/* Reset count. */
|
/* Reset count. */
|
if (wheremask)
|
if (wheremask)
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
|
|
/* Generate codes to copy the temporary to lhs. */
|
/* Generate codes to copy the temporary to lhs. */
|
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
|
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
|
wheremask, invert);
|
wheremask, invert);
|
|
|
/* Generate body and loops according to the information in
|
/* Generate body and loops according to the information in
|
nested_forall_info. */
|
nested_forall_info. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
if (ptemp1)
|
if (ptemp1)
|
{
|
{
|
/* Free the temporary. */
|
/* Free the temporary. */
|
tmp = gfc_call_free (ptemp1);
|
tmp = gfc_call_free (ptemp1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Translate pointer assignment inside FORALL which need temporary. */
|
/* Translate pointer assignment inside FORALL which need temporary. */
|
|
|
static void
|
static void
|
gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
|
gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
|
forall_info * nested_forall_info,
|
forall_info * nested_forall_info,
|
stmtblock_t * block)
|
stmtblock_t * block)
|
{
|
{
|
tree type;
|
tree type;
|
tree inner_size;
|
tree inner_size;
|
gfc_ss *lss, *rss;
|
gfc_ss *lss, *rss;
|
gfc_se lse;
|
gfc_se lse;
|
gfc_se rse;
|
gfc_se rse;
|
gfc_array_info *info;
|
gfc_array_info *info;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
tree desc;
|
tree desc;
|
tree parm;
|
tree parm;
|
tree parmtype;
|
tree parmtype;
|
stmtblock_t body;
|
stmtblock_t body;
|
tree count;
|
tree count;
|
tree tmp, tmp1, ptemp1;
|
tree tmp, tmp1, ptemp1;
|
|
|
count = gfc_create_var (gfc_array_index_type, "count");
|
count = gfc_create_var (gfc_array_index_type, "count");
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
|
|
inner_size = gfc_index_one_node;
|
inner_size = gfc_index_one_node;
|
lss = gfc_walk_expr (expr1);
|
lss = gfc_walk_expr (expr1);
|
rss = gfc_walk_expr (expr2);
|
rss = gfc_walk_expr (expr2);
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
type = gfc_typenode_for_spec (&expr1->ts);
|
type = gfc_typenode_for_spec (&expr1->ts);
|
type = build_pointer_type (type);
|
type = build_pointer_type (type);
|
|
|
/* Allocate temporary for nested forall construct according to the
|
/* Allocate temporary for nested forall construct according to the
|
information in nested_forall_info and inner_size. */
|
information in nested_forall_info and inner_size. */
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
|
inner_size, NULL, block, &ptemp1);
|
inner_size, NULL, block, &ptemp1);
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
rse.want_pointer = 1;
|
rse.want_pointer = 1;
|
gfc_conv_expr (&rse, expr2);
|
gfc_conv_expr (&rse, expr2);
|
gfc_add_block_to_block (&body, &rse.pre);
|
gfc_add_block_to_block (&body, &rse.pre);
|
gfc_add_modify (&body, lse.expr,
|
gfc_add_modify (&body, lse.expr,
|
fold_convert (TREE_TYPE (lse.expr), rse.expr));
|
fold_convert (TREE_TYPE (lse.expr), rse.expr));
|
gfc_add_block_to_block (&body, &rse.post);
|
gfc_add_block_to_block (&body, &rse.post);
|
|
|
/* Increment count. */
|
/* Increment count. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count, gfc_index_one_node);
|
count, gfc_index_one_node);
|
gfc_add_modify (&body, count, tmp);
|
gfc_add_modify (&body, count, tmp);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
/* Generate body and loops according to the information in
|
/* Generate body and loops according to the information in
|
nested_forall_info. */
|
nested_forall_info. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
/* Reset count. */
|
/* Reset count. */
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
|
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
rse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
rse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
lse.want_pointer = 1;
|
lse.want_pointer = 1;
|
gfc_conv_expr (&lse, expr1);
|
gfc_conv_expr (&lse, expr1);
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_modify (&body, lse.expr, rse.expr);
|
gfc_add_modify (&body, lse.expr, rse.expr);
|
gfc_add_block_to_block (&body, &lse.post);
|
gfc_add_block_to_block (&body, &lse.post);
|
/* Increment count. */
|
/* Increment count. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count, gfc_index_one_node);
|
count, gfc_index_one_node);
|
gfc_add_modify (&body, count, tmp);
|
gfc_add_modify (&body, count, tmp);
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
/* Generate body and loops according to the information in
|
/* Generate body and loops according to the information in
|
nested_forall_info. */
|
nested_forall_info. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* Associate the SS with the loop. */
|
/* Associate the SS with the loop. */
|
gfc_add_ss_to_loop (&loop, rss);
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
/* Setup the scalarizing loops and bounds. */
|
/* Setup the scalarizing loops and bounds. */
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
|
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
|
|
info = &rss->info->data.array;
|
info = &rss->info->data.array;
|
desc = info->descriptor;
|
desc = info->descriptor;
|
|
|
/* Make a new descriptor. */
|
/* Make a new descriptor. */
|
parmtype = gfc_get_element_type (TREE_TYPE (desc));
|
parmtype = gfc_get_element_type (TREE_TYPE (desc));
|
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
|
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
|
loop.from, loop.to, 1,
|
loop.from, loop.to, 1,
|
GFC_ARRAY_UNKNOWN, true);
|
GFC_ARRAY_UNKNOWN, true);
|
|
|
/* Allocate temporary for nested forall construct. */
|
/* Allocate temporary for nested forall construct. */
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
|
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
|
inner_size, NULL, block, &ptemp1);
|
inner_size, NULL, block, &ptemp1);
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
lse.expr = gfc_build_array_ref (tmp1, count, NULL);
|
lse.direct_byref = 1;
|
lse.direct_byref = 1;
|
rss = gfc_walk_expr (expr2);
|
rss = gfc_walk_expr (expr2);
|
gfc_conv_expr_descriptor (&lse, expr2, rss);
|
gfc_conv_expr_descriptor (&lse, expr2, rss);
|
|
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_block_to_block (&body, &lse.post);
|
gfc_add_block_to_block (&body, &lse.post);
|
|
|
/* Increment count. */
|
/* Increment count. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count, gfc_index_one_node);
|
count, gfc_index_one_node);
|
gfc_add_modify (&body, count, tmp);
|
gfc_add_modify (&body, count, tmp);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
/* Generate body and loops according to the information in
|
/* Generate body and loops according to the information in
|
nested_forall_info. */
|
nested_forall_info. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
/* Reset count. */
|
/* Reset count. */
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
|
|
parm = gfc_build_array_ref (tmp1, count, NULL);
|
parm = gfc_build_array_ref (tmp1, count, NULL);
|
lss = gfc_walk_expr (expr1);
|
lss = gfc_walk_expr (expr1);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_conv_expr_descriptor (&lse, expr1, lss);
|
gfc_conv_expr_descriptor (&lse, expr1, lss);
|
gfc_add_modify (&lse.pre, lse.expr, parm);
|
gfc_add_modify (&lse.pre, lse.expr, parm);
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_block_to_block (&body, &lse.pre);
|
gfc_add_block_to_block (&body, &lse.post);
|
gfc_add_block_to_block (&body, &lse.post);
|
|
|
/* Increment count. */
|
/* Increment count. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count, gfc_index_one_node);
|
count, gfc_index_one_node);
|
gfc_add_modify (&body, count, tmp);
|
gfc_add_modify (&body, count, tmp);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
/* Free the temporary. */
|
/* Free the temporary. */
|
if (ptemp1)
|
if (ptemp1)
|
{
|
{
|
tmp = gfc_call_free (ptemp1);
|
tmp = gfc_call_free (ptemp1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* FORALL and WHERE statements are really nasty, especially when you nest
|
/* FORALL and WHERE statements are really nasty, especially when you nest
|
them. All the rhs of a forall assignment must be evaluated before the
|
them. All the rhs of a forall assignment must be evaluated before the
|
actual assignments are performed. Presumably this also applies to all the
|
actual assignments are performed. Presumably this also applies to all the
|
assignments in an inner where statement. */
|
assignments in an inner where statement. */
|
|
|
/* Generate code for a FORALL statement. Any temporaries are allocated as a
|
/* Generate code for a FORALL statement. Any temporaries are allocated as a
|
linear array, relying on the fact that we process in the same order in all
|
linear array, relying on the fact that we process in the same order in all
|
loops.
|
loops.
|
|
|
forall (i=start:end:stride; maskexpr)
|
forall (i=start:end:stride; maskexpr)
|
e<i> = f<i>
|
e<i> = f<i>
|
g<i> = h<i>
|
g<i> = h<i>
|
end forall
|
end forall
|
(where e,f,g,h<i> are arbitrary expressions possibly involving i)
|
(where e,f,g,h<i> are arbitrary expressions possibly involving i)
|
Translates to:
|
Translates to:
|
count = ((end + 1 - start) / stride)
|
count = ((end + 1 - start) / stride)
|
masktmp(:) = maskexpr(:)
|
masktmp(:) = maskexpr(:)
|
|
|
maskindex = 0;
|
maskindex = 0;
|
for (i = start; i <= end; i += stride)
|
for (i = start; i <= end; i += stride)
|
{
|
{
|
if (masktmp[maskindex++])
|
if (masktmp[maskindex++])
|
e<i> = f<i>
|
e<i> = f<i>
|
}
|
}
|
maskindex = 0;
|
maskindex = 0;
|
for (i = start; i <= end; i += stride)
|
for (i = start; i <= end; i += stride)
|
{
|
{
|
if (masktmp[maskindex++])
|
if (masktmp[maskindex++])
|
g<i> = h<i>
|
g<i> = h<i>
|
}
|
}
|
|
|
Note that this code only works when there are no dependencies.
|
Note that this code only works when there are no dependencies.
|
Forall loop with array assignments and data dependencies are a real pain,
|
Forall loop with array assignments and data dependencies are a real pain,
|
because the size of the temporary cannot always be determined before the
|
because the size of the temporary cannot always be determined before the
|
loop is executed. This problem is compounded by the presence of nested
|
loop is executed. This problem is compounded by the presence of nested
|
FORALL constructs.
|
FORALL constructs.
|
*/
|
*/
|
|
|
static tree
|
static tree
|
gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
|
gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
|
{
|
{
|
stmtblock_t pre;
|
stmtblock_t pre;
|
stmtblock_t post;
|
stmtblock_t post;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t body;
|
stmtblock_t body;
|
tree *var;
|
tree *var;
|
tree *start;
|
tree *start;
|
tree *end;
|
tree *end;
|
tree *step;
|
tree *step;
|
gfc_expr **varexpr;
|
gfc_expr **varexpr;
|
tree tmp;
|
tree tmp;
|
tree assign;
|
tree assign;
|
tree size;
|
tree size;
|
tree maskindex;
|
tree maskindex;
|
tree mask;
|
tree mask;
|
tree pmask;
|
tree pmask;
|
tree cycle_label = NULL_TREE;
|
tree cycle_label = NULL_TREE;
|
int n;
|
int n;
|
int nvar;
|
int nvar;
|
int need_temp;
|
int need_temp;
|
gfc_forall_iterator *fa;
|
gfc_forall_iterator *fa;
|
gfc_se se;
|
gfc_se se;
|
gfc_code *c;
|
gfc_code *c;
|
gfc_saved_var *saved_vars;
|
gfc_saved_var *saved_vars;
|
iter_info *this_forall;
|
iter_info *this_forall;
|
forall_info *info;
|
forall_info *info;
|
bool need_mask;
|
bool need_mask;
|
|
|
/* Do nothing if the mask is false. */
|
/* Do nothing if the mask is false. */
|
if (code->expr1
|
if (code->expr1
|
&& code->expr1->expr_type == EXPR_CONSTANT
|
&& code->expr1->expr_type == EXPR_CONSTANT
|
&& !code->expr1->value.logical)
|
&& !code->expr1->value.logical)
|
return build_empty_stmt (input_location);
|
return build_empty_stmt (input_location);
|
|
|
n = 0;
|
n = 0;
|
/* Count the FORALL index number. */
|
/* Count the FORALL index number. */
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
n++;
|
n++;
|
nvar = n;
|
nvar = n;
|
|
|
/* Allocate the space for var, start, end, step, varexpr. */
|
/* Allocate the space for var, start, end, step, varexpr. */
|
var = XCNEWVEC (tree, nvar);
|
var = XCNEWVEC (tree, nvar);
|
start = XCNEWVEC (tree, nvar);
|
start = XCNEWVEC (tree, nvar);
|
end = XCNEWVEC (tree, nvar);
|
end = XCNEWVEC (tree, nvar);
|
step = XCNEWVEC (tree, nvar);
|
step = XCNEWVEC (tree, nvar);
|
varexpr = XCNEWVEC (gfc_expr *, nvar);
|
varexpr = XCNEWVEC (gfc_expr *, nvar);
|
saved_vars = XCNEWVEC (gfc_saved_var, nvar);
|
saved_vars = XCNEWVEC (gfc_saved_var, nvar);
|
|
|
/* Allocate the space for info. */
|
/* Allocate the space for info. */
|
info = XCNEW (forall_info);
|
info = XCNEW (forall_info);
|
|
|
gfc_start_block (&pre);
|
gfc_start_block (&pre);
|
gfc_init_block (&post);
|
gfc_init_block (&post);
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
|
|
n = 0;
|
n = 0;
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
for (fa = code->ext.forall_iterator; fa; fa = fa->next)
|
{
|
{
|
gfc_symbol *sym = fa->var->symtree->n.sym;
|
gfc_symbol *sym = fa->var->symtree->n.sym;
|
|
|
/* Allocate space for this_forall. */
|
/* Allocate space for this_forall. */
|
this_forall = XCNEW (iter_info);
|
this_forall = XCNEW (iter_info);
|
|
|
/* Create a temporary variable for the FORALL index. */
|
/* Create a temporary variable for the FORALL index. */
|
tmp = gfc_typenode_for_spec (&sym->ts);
|
tmp = gfc_typenode_for_spec (&sym->ts);
|
var[n] = gfc_create_var (tmp, sym->name);
|
var[n] = gfc_create_var (tmp, sym->name);
|
gfc_shadow_sym (sym, var[n], &saved_vars[n]);
|
gfc_shadow_sym (sym, var[n], &saved_vars[n]);
|
|
|
/* Record it in this_forall. */
|
/* Record it in this_forall. */
|
this_forall->var = var[n];
|
this_forall->var = var[n];
|
|
|
/* Replace the index symbol's backend_decl with the temporary decl. */
|
/* Replace the index symbol's backend_decl with the temporary decl. */
|
sym->backend_decl = var[n];
|
sym->backend_decl = var[n];
|
|
|
/* Work out the start, end and stride for the loop. */
|
/* Work out the start, end and stride for the loop. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, fa->start);
|
gfc_conv_expr_val (&se, fa->start);
|
/* Record it in this_forall. */
|
/* Record it in this_forall. */
|
this_forall->start = se.expr;
|
this_forall->start = se.expr;
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
start[n] = se.expr;
|
start[n] = se.expr;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, fa->end);
|
gfc_conv_expr_val (&se, fa->end);
|
/* Record it in this_forall. */
|
/* Record it in this_forall. */
|
this_forall->end = se.expr;
|
this_forall->end = se.expr;
|
gfc_make_safe_expr (&se);
|
gfc_make_safe_expr (&se);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
end[n] = se.expr;
|
end[n] = se.expr;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, fa->stride);
|
gfc_conv_expr_val (&se, fa->stride);
|
/* Record it in this_forall. */
|
/* Record it in this_forall. */
|
this_forall->step = se.expr;
|
this_forall->step = se.expr;
|
gfc_make_safe_expr (&se);
|
gfc_make_safe_expr (&se);
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
step[n] = se.expr;
|
step[n] = se.expr;
|
|
|
/* Set the NEXT field of this_forall to NULL. */
|
/* Set the NEXT field of this_forall to NULL. */
|
this_forall->next = NULL;
|
this_forall->next = NULL;
|
/* Link this_forall to the info construct. */
|
/* Link this_forall to the info construct. */
|
if (info->this_loop)
|
if (info->this_loop)
|
{
|
{
|
iter_info *iter_tmp = info->this_loop;
|
iter_info *iter_tmp = info->this_loop;
|
while (iter_tmp->next != NULL)
|
while (iter_tmp->next != NULL)
|
iter_tmp = iter_tmp->next;
|
iter_tmp = iter_tmp->next;
|
iter_tmp->next = this_forall;
|
iter_tmp->next = this_forall;
|
}
|
}
|
else
|
else
|
info->this_loop = this_forall;
|
info->this_loop = this_forall;
|
|
|
n++;
|
n++;
|
}
|
}
|
nvar = n;
|
nvar = n;
|
|
|
/* Calculate the size needed for the current forall level. */
|
/* Calculate the size needed for the current forall level. */
|
size = gfc_index_one_node;
|
size = gfc_index_one_node;
|
for (n = 0; n < nvar; n++)
|
for (n = 0; n < nvar; n++)
|
{
|
{
|
/* size = (end + step - start) / step. */
|
/* size = (end + step - start) / step. */
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
|
tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
|
step[n], start[n]);
|
step[n], start[n]);
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
|
end[n], tmp);
|
end[n], tmp);
|
tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
|
tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
|
tmp, step[n]);
|
tmp, step[n]);
|
tmp = convert (gfc_array_index_type, tmp);
|
tmp = convert (gfc_array_index_type, tmp);
|
|
|
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
|
size, tmp);
|
size, tmp);
|
}
|
}
|
|
|
/* Record the nvar and size of current forall level. */
|
/* Record the nvar and size of current forall level. */
|
info->nvar = nvar;
|
info->nvar = nvar;
|
info->size = size;
|
info->size = size;
|
|
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
/* If the mask is .true., consider the FORALL unconditional. */
|
/* If the mask is .true., consider the FORALL unconditional. */
|
if (code->expr1->expr_type == EXPR_CONSTANT
|
if (code->expr1->expr_type == EXPR_CONSTANT
|
&& code->expr1->value.logical)
|
&& code->expr1->value.logical)
|
need_mask = false;
|
need_mask = false;
|
else
|
else
|
need_mask = true;
|
need_mask = true;
|
}
|
}
|
else
|
else
|
need_mask = false;
|
need_mask = false;
|
|
|
/* First we need to allocate the mask. */
|
/* First we need to allocate the mask. */
|
if (need_mask)
|
if (need_mask)
|
{
|
{
|
/* As the mask array can be very big, prefer compact boolean types. */
|
/* As the mask array can be very big, prefer compact boolean types. */
|
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
|
mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
|
size, NULL, &block, &pmask);
|
size, NULL, &block, &pmask);
|
maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
|
maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
|
|
|
/* Record them in the info structure. */
|
/* Record them in the info structure. */
|
info->maskindex = maskindex;
|
info->maskindex = maskindex;
|
info->mask = mask;
|
info->mask = mask;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* No mask was specified. */
|
/* No mask was specified. */
|
maskindex = NULL_TREE;
|
maskindex = NULL_TREE;
|
mask = pmask = NULL_TREE;
|
mask = pmask = NULL_TREE;
|
}
|
}
|
|
|
/* Link the current forall level to nested_forall_info. */
|
/* Link the current forall level to nested_forall_info. */
|
info->prev_nest = nested_forall_info;
|
info->prev_nest = nested_forall_info;
|
nested_forall_info = info;
|
nested_forall_info = info;
|
|
|
/* Copy the mask into a temporary variable if required.
|
/* 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 (need_mask)
|
if (need_mask)
|
{
|
{
|
/* As the mask array can be very big, prefer compact boolean types. */
|
/* As the mask array can be very big, prefer compact boolean types. */
|
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
|
|
gfc_add_modify (&block, maskindex, gfc_index_zero_node);
|
gfc_add_modify (&block, maskindex, gfc_index_zero_node);
|
|
|
/* Start of mask assignment loop body. */
|
/* Start of mask assignment loop body. */
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
/* Evaluate the mask expression. */
|
/* Evaluate the mask expression. */
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_conv_expr_val (&se, code->expr1);
|
gfc_add_block_to_block (&body, &se.pre);
|
gfc_add_block_to_block (&body, &se.pre);
|
|
|
/* Store the mask. */
|
/* Store the mask. */
|
se.expr = convert (mask_type, se.expr);
|
se.expr = convert (mask_type, se.expr);
|
|
|
tmp = gfc_build_array_ref (mask, maskindex, NULL);
|
tmp = gfc_build_array_ref (mask, maskindex, NULL);
|
gfc_add_modify (&body, tmp, se.expr);
|
gfc_add_modify (&body, tmp, se.expr);
|
|
|
/* Advance to the next mask element. */
|
/* Advance to the next mask element. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
maskindex, gfc_index_one_node);
|
maskindex, gfc_index_one_node);
|
gfc_add_modify (&body, maskindex, tmp);
|
gfc_add_modify (&body, maskindex, tmp);
|
|
|
/* Generate the loops. */
|
/* Generate the loops. */
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
|
tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
if (code->op == EXEC_DO_CONCURRENT)
|
if (code->op == EXEC_DO_CONCURRENT)
|
{
|
{
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
cycle_label = gfc_build_label_decl (NULL_TREE);
|
code->cycle_label = cycle_label;
|
code->cycle_label = cycle_label;
|
tmp = gfc_trans_code (code->block->next);
|
tmp = gfc_trans_code (code->block->next);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
if (TREE_USED (cycle_label))
|
if (TREE_USED (cycle_label))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
tmp = build1_v (LABEL_EXPR, cycle_label);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
}
|
}
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
goto done;
|
goto done;
|
}
|
}
|
|
|
c = code->block->next;
|
c = code->block->next;
|
|
|
/* TODO: loop merging in FORALL statements. */
|
/* TODO: loop merging in FORALL statements. */
|
/* Now that we've got a copy of the mask, generate the assignment loops. */
|
/* Now that we've got a copy of the mask, generate the assignment loops. */
|
while (c)
|
while (c)
|
{
|
{
|
switch (c->op)
|
switch (c->op)
|
{
|
{
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
/* A scalar or array assignment. DO the simple check for
|
/* A scalar or array assignment. DO the simple check for
|
lhs to rhs dependencies. These make a temporary for the
|
lhs to rhs dependencies. These make a temporary for the
|
rhs and form a second forall block to copy to variable. */
|
rhs and form a second forall block to copy to variable. */
|
need_temp = check_forall_dependencies(c, &pre, &post);
|
need_temp = check_forall_dependencies(c, &pre, &post);
|
|
|
/* Temporaries due to array assignment data dependencies introduce
|
/* Temporaries due to array assignment data dependencies introduce
|
no end of problems. */
|
no end of problems. */
|
if (need_temp)
|
if (need_temp)
|
gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
|
gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
|
nested_forall_info, &block);
|
nested_forall_info, &block);
|
else
|
else
|
{
|
{
|
/* Use the normal assignment copying routines. */
|
/* Use the normal assignment copying routines. */
|
assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
|
assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
|
|
|
/* Generate body and loops. */
|
/* Generate body and loops. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
assign, 1);
|
assign, 1);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* Cleanup any temporary symtrees that have been made to deal
|
/* Cleanup any temporary symtrees that have been made to deal
|
with dependencies. */
|
with dependencies. */
|
if (new_symtree)
|
if (new_symtree)
|
cleanup_forall_symtrees (c);
|
cleanup_forall_symtrees (c);
|
|
|
break;
|
break;
|
|
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
/* Translate WHERE or WHERE construct nested in FORALL. */
|
/* Translate WHERE or WHERE construct nested in FORALL. */
|
gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
|
gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
|
break;
|
break;
|
|
|
/* Pointer assignment inside FORALL. */
|
/* Pointer assignment inside FORALL. */
|
case EXEC_POINTER_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
|
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
|
if (need_temp)
|
if (need_temp)
|
gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
|
gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
|
nested_forall_info, &block);
|
nested_forall_info, &block);
|
else
|
else
|
{
|
{
|
/* Use the normal assignment copying routines. */
|
/* Use the normal assignment copying routines. */
|
assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
|
assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
|
|
|
/* Generate body and loops. */
|
/* Generate body and loops. */
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
assign, 1);
|
assign, 1);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
break;
|
break;
|
|
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
tmp = gfc_trans_forall_1 (c, nested_forall_info);
|
tmp = gfc_trans_forall_1 (c, nested_forall_info);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
break;
|
break;
|
|
|
/* Explicit subroutine calls are prevented by the frontend but interface
|
/* Explicit subroutine calls are prevented by the frontend but interface
|
assignments can legitimately produce them. */
|
assignments can legitimately produce them. */
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
|
assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
break;
|
break;
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
c = c->next;
|
c = c->next;
|
}
|
}
|
|
|
done:
|
done:
|
/* Restore the original index variables. */
|
/* Restore the original index variables. */
|
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
|
for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
|
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
|
gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
|
|
|
/* Free the space for var, start, end, step, varexpr. */
|
/* Free the space for var, start, end, step, varexpr. */
|
free (var);
|
free (var);
|
free (start);
|
free (start);
|
free (end);
|
free (end);
|
free (step);
|
free (step);
|
free (varexpr);
|
free (varexpr);
|
free (saved_vars);
|
free (saved_vars);
|
|
|
for (this_forall = info->this_loop; this_forall;)
|
for (this_forall = info->this_loop; this_forall;)
|
{
|
{
|
iter_info *next = this_forall->next;
|
iter_info *next = this_forall->next;
|
free (this_forall);
|
free (this_forall);
|
this_forall = next;
|
this_forall = next;
|
}
|
}
|
|
|
/* Free the space for this forall_info. */
|
/* Free the space for this forall_info. */
|
free (info);
|
free (info);
|
|
|
if (pmask)
|
if (pmask)
|
{
|
{
|
/* Free the temporary for the mask. */
|
/* Free the temporary for the mask. */
|
tmp = gfc_call_free (pmask);
|
tmp = gfc_call_free (pmask);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
if (maskindex)
|
if (maskindex)
|
pushdecl (maskindex);
|
pushdecl (maskindex);
|
|
|
gfc_add_block_to_block (&pre, &block);
|
gfc_add_block_to_block (&pre, &block);
|
gfc_add_block_to_block (&pre, &post);
|
gfc_add_block_to_block (&pre, &post);
|
|
|
return gfc_finish_block (&pre);
|
return gfc_finish_block (&pre);
|
}
|
}
|
|
|
|
|
/* Translate the FORALL statement or construct. */
|
/* Translate the FORALL statement or construct. */
|
|
|
tree gfc_trans_forall (gfc_code * code)
|
tree gfc_trans_forall (gfc_code * code)
|
{
|
{
|
return gfc_trans_forall_1 (code, NULL);
|
return gfc_trans_forall_1 (code, NULL);
|
}
|
}
|
|
|
|
|
/* Translate the DO CONCURRENT construct. */
|
/* Translate the DO CONCURRENT construct. */
|
|
|
tree gfc_trans_do_concurrent (gfc_code * code)
|
tree gfc_trans_do_concurrent (gfc_code * code)
|
{
|
{
|
return gfc_trans_forall_1 (code, NULL);
|
return gfc_trans_forall_1 (code, NULL);
|
}
|
}
|
|
|
|
|
/* Evaluate the WHERE mask expression, copy its value to a temporary.
|
/* Evaluate the WHERE mask expression, copy its value to a temporary.
|
If the WHERE construct is nested in FORALL, compute the overall temporary
|
If the WHERE construct is nested in FORALL, compute the overall temporary
|
needed by the WHERE mask expression multiplied by the iterator number of
|
needed by the WHERE mask expression multiplied by the iterator number of
|
the nested forall.
|
the nested forall.
|
ME is the WHERE mask expression.
|
ME is the WHERE mask expression.
|
MASK is the current execution mask upon input, whose sense may or may
|
MASK is the current execution mask upon input, whose sense may or may
|
not be inverted as specified by the INVERT argument.
|
not be inverted as specified by the INVERT argument.
|
CMASK is the updated execution mask on output, or NULL if not required.
|
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.
|
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. */
|
BLOCK is the block in which to place the condition evaluation loops. */
|
|
|
static void
|
static void
|
gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
|
gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
|
tree mask, bool invert, tree cmask, tree pmask,
|
tree mask, bool invert, tree cmask, tree pmask,
|
tree mask_type, stmtblock_t * block)
|
tree mask_type, stmtblock_t * block)
|
{
|
{
|
tree tmp, tmp1;
|
tree tmp, tmp1;
|
gfc_ss *lss, *rss;
|
gfc_ss *lss, *rss;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
stmtblock_t body, body1;
|
stmtblock_t body, body1;
|
tree count, cond, mtmp;
|
tree count, cond, mtmp;
|
gfc_se lse, rse;
|
gfc_se lse, rse;
|
|
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
lss = gfc_walk_expr (me);
|
lss = gfc_walk_expr (me);
|
rss = gfc_walk_expr (me);
|
rss = gfc_walk_expr (me);
|
|
|
/* Variable to index the temporary. */
|
/* Variable to index the temporary. */
|
count = gfc_create_var (gfc_array_index_type, "count");
|
count = gfc_create_var (gfc_array_index_type, "count");
|
/* Initialize count. */
|
/* Initialize count. */
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
gfc_add_modify (block, count, gfc_index_zero_node);
|
|
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
gfc_init_block (&body1);
|
gfc_init_block (&body1);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Initialize the loop. */
|
/* Initialize the loop. */
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* We may need LSS to determine the shape of the expression. */
|
/* We may need LSS to determine the shape of the expression. */
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, rss);
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_loop_setup (&loop, &me->where);
|
gfc_conv_loop_setup (&loop, &me->where);
|
|
|
gfc_mark_ss_chain_used (rss, 1);
|
gfc_mark_ss_chain_used (rss, 1);
|
/* Start the loop body. */
|
/* Start the loop body. */
|
gfc_start_scalarized_body (&loop, &body1);
|
gfc_start_scalarized_body (&loop, &body1);
|
|
|
/* Translate the expression. */
|
/* Translate the expression. */
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
rse.ss = rss;
|
rse.ss = rss;
|
gfc_conv_expr (&rse, me);
|
gfc_conv_expr (&rse, me);
|
}
|
}
|
|
|
/* Variable to evaluate mask condition. */
|
/* Variable to evaluate mask condition. */
|
cond = gfc_create_var (mask_type, "cond");
|
cond = gfc_create_var (mask_type, "cond");
|
if (mask && (cmask || pmask))
|
if (mask && (cmask || pmask))
|
mtmp = gfc_create_var (mask_type, "mask");
|
mtmp = gfc_create_var (mask_type, "mask");
|
else mtmp = NULL_TREE;
|
else mtmp = NULL_TREE;
|
|
|
gfc_add_block_to_block (&body1, &lse.pre);
|
gfc_add_block_to_block (&body1, &lse.pre);
|
gfc_add_block_to_block (&body1, &rse.pre);
|
gfc_add_block_to_block (&body1, &rse.pre);
|
|
|
gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
|
gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
|
|
|
if (mask && (cmask || pmask))
|
if (mask && (cmask || pmask))
|
{
|
{
|
tmp = gfc_build_array_ref (mask, count, NULL);
|
tmp = gfc_build_array_ref (mask, count, NULL);
|
if (invert)
|
if (invert)
|
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
|
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
|
gfc_add_modify (&body1, mtmp, tmp);
|
gfc_add_modify (&body1, mtmp, tmp);
|
}
|
}
|
|
|
if (cmask)
|
if (cmask)
|
{
|
{
|
tmp1 = gfc_build_array_ref (cmask, count, NULL);
|
tmp1 = gfc_build_array_ref (cmask, count, NULL);
|
tmp = cond;
|
tmp = cond;
|
if (mask)
|
if (mask)
|
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
|
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
|
mtmp, tmp);
|
mtmp, tmp);
|
gfc_add_modify (&body1, tmp1, tmp);
|
gfc_add_modify (&body1, tmp1, tmp);
|
}
|
}
|
|
|
if (pmask)
|
if (pmask)
|
{
|
{
|
tmp1 = gfc_build_array_ref (pmask, count, NULL);
|
tmp1 = gfc_build_array_ref (pmask, count, NULL);
|
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
|
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
|
if (mask)
|
if (mask)
|
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
|
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
|
tmp);
|
tmp);
|
gfc_add_modify (&body1, tmp1, tmp);
|
gfc_add_modify (&body1, tmp1, tmp);
|
}
|
}
|
|
|
gfc_add_block_to_block (&body1, &lse.post);
|
gfc_add_block_to_block (&body1, &lse.post);
|
gfc_add_block_to_block (&body1, &rse.post);
|
gfc_add_block_to_block (&body1, &rse.post);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
gfc_add_block_to_block (&body, &body1);
|
gfc_add_block_to_block (&body, &body1);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Increment count. */
|
/* Increment count. */
|
tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count, gfc_index_one_node);
|
count, gfc_index_one_node);
|
gfc_add_modify (&body1, count, tmp1);
|
gfc_add_modify (&body1, count, tmp1);
|
|
|
/* Generate the copying loops. */
|
/* Generate the copying loops. */
|
gfc_trans_scalarizing_loops (&loop, &body1);
|
gfc_trans_scalarizing_loops (&loop, &body1);
|
|
|
gfc_add_block_to_block (&body, &loop.pre);
|
gfc_add_block_to_block (&body, &loop.pre);
|
gfc_add_block_to_block (&body, &loop.post);
|
gfc_add_block_to_block (&body, &loop.post);
|
|
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
/* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
|
/* 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. */
|
}
|
}
|
|
|
tmp1 = gfc_finish_block (&body);
|
tmp1 = gfc_finish_block (&body);
|
/* If the WHERE construct is inside FORALL, fill the full temporary. */
|
/* If the WHERE construct is inside FORALL, fill the full temporary. */
|
if (nested_forall_info != NULL)
|
if (nested_forall_info != NULL)
|
tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
|
tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
|
|
|
gfc_add_expr_to_block (block, tmp1);
|
gfc_add_expr_to_block (block, tmp1);
|
}
|
}
|
|
|
|
|
/* Translate an assignment statement in a WHERE statement or construct
|
/* Translate an assignment statement in a WHERE statement or construct
|
statement. The MASK expression is used to control which elements
|
statement. The MASK expression is used to control which elements
|
of EXPR1 shall be assigned. The sense of MASK is specified by
|
of EXPR1 shall be assigned. The sense of MASK is specified by
|
INVERT. */
|
INVERT. */
|
|
|
static tree
|
static tree
|
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
|
gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
|
tree mask, bool invert,
|
tree mask, bool invert,
|
tree count1, tree count2,
|
tree count1, tree count2,
|
gfc_code *cnext)
|
gfc_code *cnext)
|
{
|
{
|
gfc_se lse;
|
gfc_se lse;
|
gfc_se rse;
|
gfc_se rse;
|
gfc_ss *lss;
|
gfc_ss *lss;
|
gfc_ss *lss_section;
|
gfc_ss *lss_section;
|
gfc_ss *rss;
|
gfc_ss *rss;
|
|
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
tree tmp;
|
tree tmp;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t body;
|
stmtblock_t body;
|
tree index, maskexpr;
|
tree index, maskexpr;
|
|
|
/* A defined assignment. */
|
/* A defined assignment. */
|
if (cnext && cnext->resolved_sym)
|
if (cnext && cnext->resolved_sym)
|
return gfc_trans_call (cnext, true, mask, count1, invert);
|
return gfc_trans_call (cnext, true, mask, count1, invert);
|
|
|
#if 0
|
#if 0
|
/* TODO: handle this special case.
|
/* TODO: handle this special case.
|
Special case a single function returning an array. */
|
Special case a single function returning an array. */
|
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
|
if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
|
{
|
{
|
tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
|
tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
|
if (tmp)
|
if (tmp)
|
return tmp;
|
return tmp;
|
}
|
}
|
#endif
|
#endif
|
|
|
/* Assignment of the form lhs = rhs. */
|
/* Assignment of the form lhs = rhs. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
|
|
/* Walk the lhs. */
|
/* Walk the lhs. */
|
lss = gfc_walk_expr (expr1);
|
lss = gfc_walk_expr (expr1);
|
rss = NULL;
|
rss = NULL;
|
|
|
/* In each where-assign-stmt, the mask-expr and the variable being
|
/* In each where-assign-stmt, the mask-expr and the variable being
|
defined shall be arrays of the same shape. */
|
defined shall be arrays of the same shape. */
|
gcc_assert (lss != gfc_ss_terminator);
|
gcc_assert (lss != gfc_ss_terminator);
|
|
|
/* The assignment needs scalarization. */
|
/* The assignment needs scalarization. */
|
lss_section = lss;
|
lss_section = lss;
|
|
|
/* Find a non-scalar SS from the lhs. */
|
/* Find a non-scalar SS from the lhs. */
|
while (lss_section != gfc_ss_terminator
|
while (lss_section != gfc_ss_terminator
|
&& lss_section->info->type != GFC_SS_SECTION)
|
&& lss_section->info->type != GFC_SS_SECTION)
|
lss_section = lss_section->next;
|
lss_section = lss_section->next;
|
|
|
gcc_assert (lss_section != gfc_ss_terminator);
|
gcc_assert (lss_section != gfc_ss_terminator);
|
|
|
/* Initialize the scalarizer. */
|
/* Initialize the scalarizer. */
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* Walk the rhs. */
|
/* Walk the rhs. */
|
rss = gfc_walk_expr (expr2);
|
rss = gfc_walk_expr (expr2);
|
if (rss == gfc_ss_terminator)
|
if (rss == gfc_ss_terminator)
|
{
|
{
|
/* The rhs is scalar. Add a ss for the expression. */
|
/* The rhs is scalar. Add a ss for the expression. */
|
rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
|
rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
|
rss->info->where = 1;
|
rss->info->where = 1;
|
}
|
}
|
|
|
/* Associate the SS with the loop. */
|
/* Associate the SS with the loop. */
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, lss);
|
gfc_add_ss_to_loop (&loop, rss);
|
gfc_add_ss_to_loop (&loop, rss);
|
|
|
/* Calculate the bounds of the scalarization. */
|
/* Calculate the bounds of the scalarization. */
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
|
|
/* Resolve any data dependencies in the statement. */
|
/* Resolve any data dependencies in the statement. */
|
gfc_conv_resolve_dependencies (&loop, lss_section, rss);
|
gfc_conv_resolve_dependencies (&loop, lss_section, rss);
|
|
|
/* Setup the scalarizing loops. */
|
/* Setup the scalarizing loops. */
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
gfc_conv_loop_setup (&loop, &expr2->where);
|
|
|
/* Setup the gfc_se structures. */
|
/* Setup the gfc_se structures. */
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
rse.ss = rss;
|
rse.ss = rss;
|
gfc_mark_ss_chain_used (rss, 1);
|
gfc_mark_ss_chain_used (rss, 1);
|
if (loop.temp_ss == NULL)
|
if (loop.temp_ss == NULL)
|
{
|
{
|
lse.ss = lss;
|
lse.ss = lss;
|
gfc_mark_ss_chain_used (lss, 1);
|
gfc_mark_ss_chain_used (lss, 1);
|
}
|
}
|
else
|
else
|
{
|
{
|
lse.ss = loop.temp_ss;
|
lse.ss = loop.temp_ss;
|
gfc_mark_ss_chain_used (lss, 3);
|
gfc_mark_ss_chain_used (lss, 3);
|
gfc_mark_ss_chain_used (loop.temp_ss, 3);
|
gfc_mark_ss_chain_used (loop.temp_ss, 3);
|
}
|
}
|
|
|
/* Start the scalarized loop body. */
|
/* Start the scalarized loop body. */
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
/* Translate the expression. */
|
/* Translate the expression. */
|
gfc_conv_expr (&rse, expr2);
|
gfc_conv_expr (&rse, expr2);
|
if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
|
if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
|
gfc_conv_tmp_array_ref (&lse);
|
gfc_conv_tmp_array_ref (&lse);
|
else
|
else
|
gfc_conv_expr (&lse, expr1);
|
gfc_conv_expr (&lse, expr1);
|
|
|
/* Form the mask expression according to the mask. */
|
/* Form the mask expression according to the mask. */
|
index = count1;
|
index = count1;
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
if (invert)
|
if (invert)
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
TREE_TYPE (maskexpr), maskexpr);
|
TREE_TYPE (maskexpr), maskexpr);
|
|
|
/* Use the scalar assignment as is. */
|
/* Use the scalar assignment as is. */
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
|
loop.temp_ss != NULL, false, true);
|
loop.temp_ss != NULL, false, true);
|
|
|
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
|
tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
|
|
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
if (lss == gfc_ss_terminator)
|
if (lss == gfc_ss_terminator)
|
{
|
{
|
/* Increment count1. */
|
/* Increment count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
|
count1, gfc_index_one_node);
|
count1, gfc_index_one_node);
|
gfc_add_modify (&body, count1, tmp);
|
gfc_add_modify (&body, count1, tmp);
|
|
|
/* Use the scalar assignment as is. */
|
/* Use the scalar assignment as is. */
|
gfc_add_block_to_block (&block, &body);
|
gfc_add_block_to_block (&block, &body);
|
}
|
}
|
else
|
else
|
{
|
{
|
gcc_assert (lse.ss == gfc_ss_terminator
|
gcc_assert (lse.ss == gfc_ss_terminator
|
&& rse.ss == gfc_ss_terminator);
|
&& rse.ss == gfc_ss_terminator);
|
|
|
if (loop.temp_ss != NULL)
|
if (loop.temp_ss != NULL)
|
{
|
{
|
/* Increment count1 before finish the main body of a scalarized
|
/* Increment count1 before finish the main body of a scalarized
|
expression. */
|
expression. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, count1, gfc_index_one_node);
|
gfc_array_index_type, count1, gfc_index_one_node);
|
gfc_add_modify (&body, count1, tmp);
|
gfc_add_modify (&body, count1, tmp);
|
gfc_trans_scalarized_loop_boundary (&loop, &body);
|
gfc_trans_scalarized_loop_boundary (&loop, &body);
|
|
|
/* We need to copy the temporary to the actual lhs. */
|
/* We need to copy the temporary to the actual lhs. */
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_init_se (&rse, NULL);
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
gfc_copy_loopinfo_to_se (&lse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
gfc_copy_loopinfo_to_se (&rse, &loop);
|
|
|
rse.ss = loop.temp_ss;
|
rse.ss = loop.temp_ss;
|
lse.ss = lss;
|
lse.ss = lss;
|
|
|
gfc_conv_tmp_array_ref (&rse);
|
gfc_conv_tmp_array_ref (&rse);
|
gfc_conv_expr (&lse, expr1);
|
gfc_conv_expr (&lse, expr1);
|
|
|
gcc_assert (lse.ss == gfc_ss_terminator
|
gcc_assert (lse.ss == gfc_ss_terminator
|
&& rse.ss == gfc_ss_terminator);
|
&& rse.ss == gfc_ss_terminator);
|
|
|
/* Form the mask expression according to the mask tree list. */
|
/* Form the mask expression according to the mask tree list. */
|
index = count2;
|
index = count2;
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
maskexpr = gfc_build_array_ref (mask, index, NULL);
|
if (invert)
|
if (invert)
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
|
TREE_TYPE (maskexpr), maskexpr);
|
TREE_TYPE (maskexpr), maskexpr);
|
|
|
/* Use the scalar assignment as is. */
|
/* Use the scalar assignment as is. */
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
|
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
|
true);
|
true);
|
tmp = build3_v (COND_EXPR, maskexpr, tmp,
|
tmp = build3_v (COND_EXPR, maskexpr, tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
|
|
/* Increment count2. */
|
/* Increment count2. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, count2,
|
gfc_array_index_type, count2,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
gfc_add_modify (&body, count2, tmp);
|
gfc_add_modify (&body, count2, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Increment count1. */
|
/* Increment count1. */
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
tmp = fold_build2_loc (input_location, PLUS_EXPR,
|
gfc_array_index_type, count1,
|
gfc_array_index_type, count1,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
gfc_add_modify (&body, count1, tmp);
|
gfc_add_modify (&body, count1, tmp);
|
}
|
}
|
|
|
/* Generate the copying loops. */
|
/* Generate the copying loops. */
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
/* Wrap the whole thing up. */
|
/* Wrap the whole thing up. */
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
}
|
}
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the WHERE construct or statement.
|
/* Translate the WHERE construct or statement.
|
This function can be called iteratively to translate the nested WHERE
|
This function can be called iteratively to translate the nested WHERE
|
construct or statement.
|
construct or statement.
|
MASK is the control mask. */
|
MASK is the control mask. */
|
|
|
static void
|
static void
|
gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
|
forall_info * nested_forall_info, stmtblock_t * block)
|
forall_info * nested_forall_info, stmtblock_t * block)
|
{
|
{
|
stmtblock_t inner_size_body;
|
stmtblock_t inner_size_body;
|
tree inner_size, size;
|
tree inner_size, size;
|
gfc_ss *lss, *rss;
|
gfc_ss *lss, *rss;
|
tree mask_type;
|
tree mask_type;
|
gfc_expr *expr1;
|
gfc_expr *expr1;
|
gfc_expr *expr2;
|
gfc_expr *expr2;
|
gfc_code *cblock;
|
gfc_code *cblock;
|
gfc_code *cnext;
|
gfc_code *cnext;
|
tree tmp;
|
tree tmp;
|
tree cond;
|
tree cond;
|
tree count1, count2;
|
tree count1, count2;
|
bool need_cmask;
|
bool need_cmask;
|
bool need_pmask;
|
bool need_pmask;
|
int need_temp;
|
int need_temp;
|
tree pcmask = NULL_TREE;
|
tree pcmask = NULL_TREE;
|
tree ppmask = NULL_TREE;
|
tree ppmask = NULL_TREE;
|
tree cmask = NULL_TREE;
|
tree cmask = NULL_TREE;
|
tree pmask = NULL_TREE;
|
tree pmask = NULL_TREE;
|
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
|
|
/* the WHERE statement or the WHERE construct statement. */
|
/* the WHERE statement or the WHERE construct statement. */
|
cblock = code->block;
|
cblock = code->block;
|
|
|
/* As the mask array can be very big, prefer compact boolean types. */
|
/* As the mask array can be very big, prefer compact boolean types. */
|
mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
|
|
|
/* Determine which temporary masks are needed. */
|
/* Determine which temporary masks are needed. */
|
if (!cblock->block)
|
if (!cblock->block)
|
{
|
{
|
/* One clause: No ELSEWHEREs. */
|
/* One clause: No ELSEWHEREs. */
|
need_cmask = (cblock->next != 0);
|
need_cmask = (cblock->next != 0);
|
need_pmask = false;
|
need_pmask = false;
|
}
|
}
|
else if (cblock->block->block)
|
else if (cblock->block->block)
|
{
|
{
|
/* Three or more clauses: Conditional ELSEWHEREs. */
|
/* Three or more clauses: Conditional ELSEWHEREs. */
|
need_cmask = true;
|
need_cmask = true;
|
need_pmask = true;
|
need_pmask = true;
|
}
|
}
|
else if (cblock->next)
|
else if (cblock->next)
|
{
|
{
|
/* Two clauses, the first non-empty. */
|
/* Two clauses, the first non-empty. */
|
need_cmask = true;
|
need_cmask = true;
|
need_pmask = (mask != NULL_TREE
|
need_pmask = (mask != NULL_TREE
|
&& cblock->block->next != 0);
|
&& cblock->block->next != 0);
|
}
|
}
|
else if (!cblock->block->next)
|
else if (!cblock->block->next)
|
{
|
{
|
/* Two clauses, both empty. */
|
/* Two clauses, both empty. */
|
need_cmask = false;
|
need_cmask = false;
|
need_pmask = false;
|
need_pmask = false;
|
}
|
}
|
/* Two clauses, the first empty, the second non-empty. */
|
/* Two clauses, the first empty, the second non-empty. */
|
else if (mask)
|
else if (mask)
|
{
|
{
|
need_cmask = (cblock->block->expr1 != 0);
|
need_cmask = (cblock->block->expr1 != 0);
|
need_pmask = true;
|
need_pmask = true;
|
}
|
}
|
else
|
else
|
{
|
{
|
need_cmask = true;
|
need_cmask = true;
|
need_pmask = false;
|
need_pmask = false;
|
}
|
}
|
|
|
if (need_cmask || need_pmask)
|
if (need_cmask || need_pmask)
|
{
|
{
|
/* Calculate the size of temporary needed by the mask-expr. */
|
/* Calculate the size of temporary needed by the mask-expr. */
|
gfc_init_block (&inner_size_body);
|
gfc_init_block (&inner_size_body);
|
inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
|
inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
|
&inner_size_body, &lss, &rss);
|
&inner_size_body, &lss, &rss);
|
|
|
gfc_free_ss_chain (lss);
|
gfc_free_ss_chain (lss);
|
gfc_free_ss_chain (rss);
|
gfc_free_ss_chain (rss);
|
|
|
/* Calculate the total size of temporary needed. */
|
/* Calculate the total size of temporary needed. */
|
size = compute_overall_iter_number (nested_forall_info, inner_size,
|
size = compute_overall_iter_number (nested_forall_info, inner_size,
|
&inner_size_body, block);
|
&inner_size_body, block);
|
|
|
/* Check whether the size is negative. */
|
/* Check whether the size is negative. */
|
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
|
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
|
gfc_index_zero_node);
|
gfc_index_zero_node);
|
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
|
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
|
cond, gfc_index_zero_node, size);
|
cond, gfc_index_zero_node, size);
|
size = gfc_evaluate_now (size, block);
|
size = gfc_evaluate_now (size, block);
|
|
|
/* Allocate temporary for WHERE mask if needed. */
|
/* Allocate temporary for WHERE mask if needed. */
|
if (need_cmask)
|
if (need_cmask)
|
cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
|
cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
|
&pcmask);
|
&pcmask);
|
|
|
/* Allocate temporary for !mask if needed. */
|
/* Allocate temporary for !mask if needed. */
|
if (need_pmask)
|
if (need_pmask)
|
pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
|
pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
|
&ppmask);
|
&ppmask);
|
}
|
}
|
|
|
while (cblock)
|
while (cblock)
|
{
|
{
|
/* Each time around this loop, the where clause is conditional
|
/* Each time around this loop, the where clause is conditional
|
on the value of mask and invert, which are updated at the
|
on the value of mask and invert, which are updated at the
|
bottom of the loop. */
|
bottom of the loop. */
|
|
|
/* Has mask-expr. */
|
/* Has mask-expr. */
|
if (cblock->expr1)
|
if (cblock->expr1)
|
{
|
{
|
/* Ensure that the WHERE mask will be evaluated exactly once.
|
/* Ensure that the WHERE mask will be evaluated exactly once.
|
If there are no statements in this WHERE/ELSEWHERE clause,
|
If there are no statements in this WHERE/ELSEWHERE clause,
|
then we don't need to update the control mask (cmask).
|
then we don't need to update the control mask (cmask).
|
If this is the last clause of the WHERE construct, then
|
If this is the last clause of the WHERE construct, then
|
we don't need to update the pending control mask (pmask). */
|
we don't need to update the pending control mask (pmask). */
|
if (mask)
|
if (mask)
|
gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
|
gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
|
mask, invert,
|
mask, invert,
|
cblock->next ? cmask : NULL_TREE,
|
cblock->next ? cmask : NULL_TREE,
|
cblock->block ? pmask : NULL_TREE,
|
cblock->block ? pmask : NULL_TREE,
|
mask_type, block);
|
mask_type, block);
|
else
|
else
|
gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
|
gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
|
NULL_TREE, false,
|
NULL_TREE, false,
|
(cblock->next || cblock->block)
|
(cblock->next || cblock->block)
|
? cmask : NULL_TREE,
|
? cmask : NULL_TREE,
|
NULL_TREE, mask_type, block);
|
NULL_TREE, mask_type, block);
|
|
|
invert = false;
|
invert = false;
|
}
|
}
|
/* It's a final elsewhere-stmt. No mask-expr is present. */
|
/* It's a final elsewhere-stmt. No mask-expr is present. */
|
else
|
else
|
cmask = mask;
|
cmask = mask;
|
|
|
/* The body of this where clause are controlled by cmask with
|
/* The body of this where clause are controlled by cmask with
|
sense specified by invert. */
|
sense specified by invert. */
|
|
|
/* Get the assignment statement of a WHERE statement, or the first
|
/* Get the assignment statement of a WHERE statement, or the first
|
statement in where-body-construct of a WHERE construct. */
|
statement in where-body-construct of a WHERE construct. */
|
cnext = cblock->next;
|
cnext = cblock->next;
|
while (cnext)
|
while (cnext)
|
{
|
{
|
switch (cnext->op)
|
switch (cnext->op)
|
{
|
{
|
/* WHERE assignment statement. */
|
/* WHERE assignment statement. */
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
|
|
arg = cnext->ext.actual;
|
arg = cnext->ext.actual;
|
expr1 = expr2 = NULL;
|
expr1 = expr2 = NULL;
|
for (; arg; arg = arg->next)
|
for (; arg; arg = arg->next)
|
{
|
{
|
if (!arg->expr)
|
if (!arg->expr)
|
continue;
|
continue;
|
if (expr1 == NULL)
|
if (expr1 == NULL)
|
expr1 = arg->expr;
|
expr1 = arg->expr;
|
else
|
else
|
expr2 = arg->expr;
|
expr2 = arg->expr;
|
}
|
}
|
goto evaluate;
|
goto evaluate;
|
|
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
expr1 = cnext->expr1;
|
expr1 = cnext->expr1;
|
expr2 = cnext->expr2;
|
expr2 = cnext->expr2;
|
evaluate:
|
evaluate:
|
if (nested_forall_info != NULL)
|
if (nested_forall_info != NULL)
|
{
|
{
|
need_temp = gfc_check_dependency (expr1, expr2, 0);
|
need_temp = gfc_check_dependency (expr1, expr2, 0);
|
if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
|
if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
|
gfc_trans_assign_need_temp (expr1, expr2,
|
gfc_trans_assign_need_temp (expr1, expr2,
|
cmask, invert,
|
cmask, invert,
|
nested_forall_info, block);
|
nested_forall_info, block);
|
else
|
else
|
{
|
{
|
/* Variables to control maskexpr. */
|
/* Variables to control maskexpr. */
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
count2 = gfc_create_var (gfc_array_index_type, "count2");
|
count2 = gfc_create_var (gfc_array_index_type, "count2");
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count2, gfc_index_zero_node);
|
gfc_add_modify (block, count2, gfc_index_zero_node);
|
|
|
tmp = gfc_trans_where_assign (expr1, expr2,
|
tmp = gfc_trans_where_assign (expr1, expr2,
|
cmask, invert,
|
cmask, invert,
|
count1, count2,
|
count1, count2,
|
cnext);
|
cnext);
|
|
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
tmp = gfc_trans_nested_forall_loop (nested_forall_info,
|
tmp, 1);
|
tmp, 1);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Variables to control maskexpr. */
|
/* Variables to control maskexpr. */
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
count1 = gfc_create_var (gfc_array_index_type, "count1");
|
count2 = gfc_create_var (gfc_array_index_type, "count2");
|
count2 = gfc_create_var (gfc_array_index_type, "count2");
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count1, gfc_index_zero_node);
|
gfc_add_modify (block, count2, gfc_index_zero_node);
|
gfc_add_modify (block, count2, gfc_index_zero_node);
|
|
|
tmp = gfc_trans_where_assign (expr1, expr2,
|
tmp = gfc_trans_where_assign (expr1, expr2,
|
cmask, invert,
|
cmask, invert,
|
count1, count2,
|
count1, count2,
|
cnext);
|
cnext);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
}
|
}
|
break;
|
break;
|
|
|
/* WHERE or WHERE construct is part of a where-body-construct. */
|
/* WHERE or WHERE construct is part of a where-body-construct. */
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
gfc_trans_where_2 (cnext, cmask, invert,
|
gfc_trans_where_2 (cnext, cmask, invert,
|
nested_forall_info, block);
|
nested_forall_info, block);
|
break;
|
break;
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
/* The next statement within the same where-body-construct. */
|
/* The next statement within the same where-body-construct. */
|
cnext = cnext->next;
|
cnext = cnext->next;
|
}
|
}
|
/* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
|
/* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
|
cblock = cblock->block;
|
cblock = cblock->block;
|
if (mask == NULL_TREE)
|
if (mask == NULL_TREE)
|
{
|
{
|
/* If we're the initial WHERE, we can simply invert the sense
|
/* If we're the initial WHERE, we can simply invert the sense
|
of the current mask to obtain the "mask" for the remaining
|
of the current mask to obtain the "mask" for the remaining
|
ELSEWHEREs. */
|
ELSEWHEREs. */
|
invert = true;
|
invert = true;
|
mask = cmask;
|
mask = cmask;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Otherwise, for nested WHERE's we need to use the pending mask. */
|
/* Otherwise, for nested WHERE's we need to use the pending mask. */
|
invert = false;
|
invert = false;
|
mask = pmask;
|
mask = pmask;
|
}
|
}
|
}
|
}
|
|
|
/* If we allocated a pending mask array, deallocate it now. */
|
/* If we allocated a pending mask array, deallocate it now. */
|
if (ppmask)
|
if (ppmask)
|
{
|
{
|
tmp = gfc_call_free (ppmask);
|
tmp = gfc_call_free (ppmask);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
|
|
/* If we allocated a current mask array, deallocate it now. */
|
/* If we allocated a current mask array, deallocate it now. */
|
if (pcmask)
|
if (pcmask)
|
{
|
{
|
tmp = gfc_call_free (pcmask);
|
tmp = gfc_call_free (pcmask);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
}
|
}
|
|
|
/* Translate a simple WHERE construct or statement without dependencies.
|
/* Translate a simple WHERE construct or statement without dependencies.
|
CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
|
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.
|
is the mask condition, and EBLOCK if non-NULL is the "else" clause.
|
Currently both CBLOCK and EBLOCK are restricted to single assignments. */
|
Currently both CBLOCK and EBLOCK are restricted to single assignments. */
|
|
|
static tree
|
static tree
|
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
|
gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
|
{
|
{
|
stmtblock_t block, body;
|
stmtblock_t block, body;
|
gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
|
gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
|
tree tmp, cexpr, tstmt, estmt;
|
tree tmp, cexpr, tstmt, estmt;
|
gfc_ss *css, *tdss, *tsss;
|
gfc_ss *css, *tdss, *tsss;
|
gfc_se cse, tdse, tsse, edse, esse;
|
gfc_se cse, tdse, tsse, edse, esse;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
gfc_ss *edss = 0;
|
gfc_ss *edss = 0;
|
gfc_ss *esss = 0;
|
gfc_ss *esss = 0;
|
|
|
/* Allow the scalarizer to workshare simple where loops. */
|
/* Allow the scalarizer to workshare simple where loops. */
|
if (ompws_flags & OMPWS_WORKSHARE_FLAG)
|
if (ompws_flags & OMPWS_WORKSHARE_FLAG)
|
ompws_flags |= OMPWS_SCALARIZER_WS;
|
ompws_flags |= OMPWS_SCALARIZER_WS;
|
|
|
cond = cblock->expr1;
|
cond = cblock->expr1;
|
tdst = cblock->next->expr1;
|
tdst = cblock->next->expr1;
|
tsrc = cblock->next->expr2;
|
tsrc = cblock->next->expr2;
|
edst = eblock ? eblock->next->expr1 : NULL;
|
edst = eblock ? eblock->next->expr1 : NULL;
|
esrc = eblock ? eblock->next->expr2 : NULL;
|
esrc = eblock ? eblock->next->expr2 : NULL;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
|
|
/* Handle the condition. */
|
/* Handle the condition. */
|
gfc_init_se (&cse, NULL);
|
gfc_init_se (&cse, NULL);
|
css = gfc_walk_expr (cond);
|
css = gfc_walk_expr (cond);
|
gfc_add_ss_to_loop (&loop, css);
|
gfc_add_ss_to_loop (&loop, css);
|
|
|
/* Handle the then-clause. */
|
/* Handle the then-clause. */
|
gfc_init_se (&tdse, NULL);
|
gfc_init_se (&tdse, NULL);
|
gfc_init_se (&tsse, NULL);
|
gfc_init_se (&tsse, NULL);
|
tdss = gfc_walk_expr (tdst);
|
tdss = gfc_walk_expr (tdst);
|
tsss = gfc_walk_expr (tsrc);
|
tsss = gfc_walk_expr (tsrc);
|
if (tsss == gfc_ss_terminator)
|
if (tsss == gfc_ss_terminator)
|
{
|
{
|
tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
|
tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
|
tsss->info->where = 1;
|
tsss->info->where = 1;
|
}
|
}
|
gfc_add_ss_to_loop (&loop, tdss);
|
gfc_add_ss_to_loop (&loop, tdss);
|
gfc_add_ss_to_loop (&loop, tsss);
|
gfc_add_ss_to_loop (&loop, tsss);
|
|
|
if (eblock)
|
if (eblock)
|
{
|
{
|
/* Handle the else clause. */
|
/* Handle the else clause. */
|
gfc_init_se (&edse, NULL);
|
gfc_init_se (&edse, NULL);
|
gfc_init_se (&esse, NULL);
|
gfc_init_se (&esse, NULL);
|
edss = gfc_walk_expr (edst);
|
edss = gfc_walk_expr (edst);
|
esss = gfc_walk_expr (esrc);
|
esss = gfc_walk_expr (esrc);
|
if (esss == gfc_ss_terminator)
|
if (esss == gfc_ss_terminator)
|
{
|
{
|
esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
|
esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
|
esss->info->where = 1;
|
esss->info->where = 1;
|
}
|
}
|
gfc_add_ss_to_loop (&loop, edss);
|
gfc_add_ss_to_loop (&loop, edss);
|
gfc_add_ss_to_loop (&loop, esss);
|
gfc_add_ss_to_loop (&loop, esss);
|
}
|
}
|
|
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_loop_setup (&loop, &tdst->where);
|
gfc_conv_loop_setup (&loop, &tdst->where);
|
|
|
gfc_mark_ss_chain_used (css, 1);
|
gfc_mark_ss_chain_used (css, 1);
|
gfc_mark_ss_chain_used (tdss, 1);
|
gfc_mark_ss_chain_used (tdss, 1);
|
gfc_mark_ss_chain_used (tsss, 1);
|
gfc_mark_ss_chain_used (tsss, 1);
|
if (eblock)
|
if (eblock)
|
{
|
{
|
gfc_mark_ss_chain_used (edss, 1);
|
gfc_mark_ss_chain_used (edss, 1);
|
gfc_mark_ss_chain_used (esss, 1);
|
gfc_mark_ss_chain_used (esss, 1);
|
}
|
}
|
|
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
gfc_copy_loopinfo_to_se (&cse, &loop);
|
gfc_copy_loopinfo_to_se (&cse, &loop);
|
gfc_copy_loopinfo_to_se (&tdse, &loop);
|
gfc_copy_loopinfo_to_se (&tdse, &loop);
|
gfc_copy_loopinfo_to_se (&tsse, &loop);
|
gfc_copy_loopinfo_to_se (&tsse, &loop);
|
cse.ss = css;
|
cse.ss = css;
|
tdse.ss = tdss;
|
tdse.ss = tdss;
|
tsse.ss = tsss;
|
tsse.ss = tsss;
|
if (eblock)
|
if (eblock)
|
{
|
{
|
gfc_copy_loopinfo_to_se (&edse, &loop);
|
gfc_copy_loopinfo_to_se (&edse, &loop);
|
gfc_copy_loopinfo_to_se (&esse, &loop);
|
gfc_copy_loopinfo_to_se (&esse, &loop);
|
edse.ss = edss;
|
edse.ss = edss;
|
esse.ss = esss;
|
esse.ss = esss;
|
}
|
}
|
|
|
gfc_conv_expr (&cse, cond);
|
gfc_conv_expr (&cse, cond);
|
gfc_add_block_to_block (&body, &cse.pre);
|
gfc_add_block_to_block (&body, &cse.pre);
|
cexpr = cse.expr;
|
cexpr = cse.expr;
|
|
|
gfc_conv_expr (&tsse, tsrc);
|
gfc_conv_expr (&tsse, tsrc);
|
if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
|
if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
|
gfc_conv_tmp_array_ref (&tdse);
|
gfc_conv_tmp_array_ref (&tdse);
|
else
|
else
|
gfc_conv_expr (&tdse, tdst);
|
gfc_conv_expr (&tdse, tdst);
|
|
|
if (eblock)
|
if (eblock)
|
{
|
{
|
gfc_conv_expr (&esse, esrc);
|
gfc_conv_expr (&esse, esrc);
|
if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
|
if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
|
gfc_conv_tmp_array_ref (&edse);
|
gfc_conv_tmp_array_ref (&edse);
|
else
|
else
|
gfc_conv_expr (&edse, edst);
|
gfc_conv_expr (&edse, edst);
|
}
|
}
|
|
|
tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
|
tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
|
estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
|
estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
|
false, true)
|
false, true)
|
: build_empty_stmt (input_location);
|
: build_empty_stmt (input_location);
|
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
|
tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_expr_to_block (&body, tmp);
|
gfc_add_block_to_block (&body, &cse.post);
|
gfc_add_block_to_block (&body, &cse.post);
|
|
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
/* As the WHERE or WHERE construct statement can be nested, we call
|
/* 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_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
|
tree
|
gfc_trans_where (gfc_code * code)
|
gfc_trans_where (gfc_code * code)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
gfc_code *cblock;
|
gfc_code *cblock;
|
gfc_code *eblock;
|
gfc_code *eblock;
|
|
|
cblock = code->block;
|
cblock = code->block;
|
if (cblock->next
|
if (cblock->next
|
&& cblock->next->op == EXEC_ASSIGN
|
&& cblock->next->op == EXEC_ASSIGN
|
&& !cblock->next->next)
|
&& !cblock->next->next)
|
{
|
{
|
eblock = cblock->block;
|
eblock = cblock->block;
|
if (!eblock)
|
if (!eblock)
|
{
|
{
|
/* A simple "WHERE (cond) x = y" statement or block is
|
/* A simple "WHERE (cond) x = y" statement or block is
|
dependence free if cond is not dependent upon writing x,
|
dependence free if cond is not dependent upon writing x,
|
and the source y is unaffected by the destination x. */
|
and the source y is unaffected by the destination x. */
|
if (!gfc_check_dependency (cblock->next->expr1,
|
if (!gfc_check_dependency (cblock->next->expr1,
|
cblock->expr1, 0)
|
cblock->expr1, 0)
|
&& !gfc_check_dependency (cblock->next->expr1,
|
&& !gfc_check_dependency (cblock->next->expr1,
|
cblock->next->expr2, 0))
|
cblock->next->expr2, 0))
|
return gfc_trans_where_3 (cblock, NULL);
|
return gfc_trans_where_3 (cblock, NULL);
|
}
|
}
|
else if (!eblock->expr1
|
else if (!eblock->expr1
|
&& !eblock->block
|
&& !eblock->block
|
&& eblock->next
|
&& eblock->next
|
&& eblock->next->op == EXEC_ASSIGN
|
&& eblock->next->op == EXEC_ASSIGN
|
&& !eblock->next->next)
|
&& !eblock->next->next)
|
{
|
{
|
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
|
/* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
|
block is dependence free if cond is not dependent on writes
|
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
|
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
|
is not dependent on writes to x1, and both y's are not
|
dependent upon their own x's. In addition to this, the
|
dependent upon their own x's. In addition to this, the
|
final two dependency checks below exclude all but the same
|
final two dependency checks below exclude all but the same
|
array reference if the where and elswhere destinations
|
array reference if the where and elswhere destinations
|
are the same. In short, this is VERY conservative and this
|
are the same. In short, this is VERY conservative and this
|
is needed because the two loops, required by the standard
|
is needed because the two loops, required by the standard
|
are coalesced in gfc_trans_where_3. */
|
are coalesced in gfc_trans_where_3. */
|
if (!gfc_check_dependency(cblock->next->expr1,
|
if (!gfc_check_dependency(cblock->next->expr1,
|
cblock->expr1, 0)
|
cblock->expr1, 0)
|
&& !gfc_check_dependency(eblock->next->expr1,
|
&& !gfc_check_dependency(eblock->next->expr1,
|
cblock->expr1, 0)
|
cblock->expr1, 0)
|
&& !gfc_check_dependency(cblock->next->expr1,
|
&& !gfc_check_dependency(cblock->next->expr1,
|
eblock->next->expr2, 1)
|
eblock->next->expr2, 1)
|
&& !gfc_check_dependency(eblock->next->expr1,
|
&& !gfc_check_dependency(eblock->next->expr1,
|
cblock->next->expr2, 1)
|
cblock->next->expr2, 1)
|
&& !gfc_check_dependency(cblock->next->expr1,
|
&& !gfc_check_dependency(cblock->next->expr1,
|
cblock->next->expr2, 1)
|
cblock->next->expr2, 1)
|
&& !gfc_check_dependency(eblock->next->expr1,
|
&& !gfc_check_dependency(eblock->next->expr1,
|
eblock->next->expr2, 1)
|
eblock->next->expr2, 1)
|
&& !gfc_check_dependency(cblock->next->expr1,
|
&& !gfc_check_dependency(cblock->next->expr1,
|
eblock->next->expr1, 0)
|
eblock->next->expr1, 0)
|
&& !gfc_check_dependency(eblock->next->expr1,
|
&& !gfc_check_dependency(eblock->next->expr1,
|
cblock->next->expr1, 0))
|
cblock->next->expr1, 0))
|
return gfc_trans_where_3 (cblock, eblock);
|
return gfc_trans_where_3 (cblock, eblock);
|
}
|
}
|
}
|
}
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
gfc_trans_where_2 (code, NULL, false, NULL, &block);
|
gfc_trans_where_2 (code, NULL, false, NULL, &block);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* CYCLE a DO loop. The label decl has already been created by
|
/* CYCLE a DO loop. The label decl has already been created by
|
gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
|
gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
|
node at the head of the loop. We must mark the label as used. */
|
node at the head of the loop. We must mark the label as used. */
|
|
|
tree
|
tree
|
gfc_trans_cycle (gfc_code * code)
|
gfc_trans_cycle (gfc_code * code)
|
{
|
{
|
tree cycle_label;
|
tree cycle_label;
|
|
|
cycle_label = code->ext.which_construct->cycle_label;
|
cycle_label = code->ext.which_construct->cycle_label;
|
gcc_assert (cycle_label);
|
gcc_assert (cycle_label);
|
|
|
TREE_USED (cycle_label) = 1;
|
TREE_USED (cycle_label) = 1;
|
return build1_v (GOTO_EXPR, cycle_label);
|
return build1_v (GOTO_EXPR, cycle_label);
|
}
|
}
|
|
|
|
|
/* EXIT a DO loop. Similar 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
|
TREE_VALUE (backend_decl) of the gfc_code node at the head of the
|
loop. */
|
loop. */
|
|
|
tree
|
tree
|
gfc_trans_exit (gfc_code * code)
|
gfc_trans_exit (gfc_code * code)
|
{
|
{
|
tree exit_label;
|
tree exit_label;
|
|
|
exit_label = code->ext.which_construct->exit_label;
|
exit_label = code->ext.which_construct->exit_label;
|
gcc_assert (exit_label);
|
gcc_assert (exit_label);
|
|
|
TREE_USED (exit_label) = 1;
|
TREE_USED (exit_label) = 1;
|
return build1_v (GOTO_EXPR, exit_label);
|
return build1_v (GOTO_EXPR, exit_label);
|
}
|
}
|
|
|
|
|
/* Translate the ALLOCATE statement. */
|
/* Translate the ALLOCATE statement. */
|
|
|
tree
|
tree
|
gfc_trans_allocate (gfc_code * code)
|
gfc_trans_allocate (gfc_code * code)
|
{
|
{
|
gfc_alloc *al;
|
gfc_alloc *al;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
tree parm;
|
tree parm;
|
tree stat;
|
tree stat;
|
tree errmsg;
|
tree errmsg;
|
tree errlen;
|
tree errlen;
|
tree label_errmsg;
|
tree label_errmsg;
|
tree label_finish;
|
tree label_finish;
|
tree memsz;
|
tree memsz;
|
tree expr3;
|
tree expr3;
|
tree slen3;
|
tree slen3;
|
stmtblock_t block;
|
stmtblock_t block;
|
stmtblock_t post;
|
stmtblock_t post;
|
gfc_expr *sz;
|
gfc_expr *sz;
|
gfc_se se_sz;
|
gfc_se se_sz;
|
tree class_expr;
|
tree class_expr;
|
tree nelems;
|
tree nelems;
|
tree memsize = NULL_TREE;
|
tree memsize = NULL_TREE;
|
tree classexpr = NULL_TREE;
|
tree classexpr = NULL_TREE;
|
|
|
if (!code->ext.alloc.list)
|
if (!code->ext.alloc.list)
|
return NULL_TREE;
|
return NULL_TREE;
|
|
|
stat = tmp = memsz = NULL_TREE;
|
stat = tmp = memsz = NULL_TREE;
|
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
|
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
|
|
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
gfc_init_block (&post);
|
gfc_init_block (&post);
|
|
|
/* STAT= (and maybe ERRMSG=) is present. */
|
/* STAT= (and maybe ERRMSG=) is present. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
/* STAT=. */
|
/* STAT=. */
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
stat = gfc_create_var (gfc_int4_type_node, "stat");
|
stat = gfc_create_var (gfc_int4_type_node, "stat");
|
|
|
/* ERRMSG= only makes sense with STAT=. */
|
/* ERRMSG= only makes sense with STAT=. */
|
if (code->expr2)
|
if (code->expr2)
|
{
|
{
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
se.want_pointer = 1;
|
se.want_pointer = 1;
|
gfc_conv_expr_lhs (&se, code->expr2);
|
gfc_conv_expr_lhs (&se, code->expr2);
|
errmsg = se.expr;
|
errmsg = se.expr;
|
errlen = se.string_length;
|
errlen = se.string_length;
|
}
|
}
|
else
|
else
|
{
|
{
|
errmsg = null_pointer_node;
|
errmsg = null_pointer_node;
|
errlen = build_int_cst (gfc_charlen_type_node, 0);
|
errlen = build_int_cst (gfc_charlen_type_node, 0);
|
}
|
}
|
|
|
/* GOTO destinations. */
|
/* GOTO destinations. */
|
label_errmsg = gfc_build_label_decl (NULL_TREE);
|
label_errmsg = gfc_build_label_decl (NULL_TREE);
|
label_finish = gfc_build_label_decl (NULL_TREE);
|
label_finish = gfc_build_label_decl (NULL_TREE);
|
TREE_USED (label_finish) = 0;
|
TREE_USED (label_finish) = 0;
|
}
|
}
|
|
|
expr3 = NULL_TREE;
|
expr3 = NULL_TREE;
|
slen3 = NULL_TREE;
|
slen3 = NULL_TREE;
|
|
|
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
{
|
{
|
expr = gfc_copy_expr (al->expr);
|
expr = gfc_copy_expr (al->expr);
|
|
|
if (expr->ts.type == BT_CLASS)
|
if (expr->ts.type == BT_CLASS)
|
gfc_add_data_component (expr);
|
gfc_add_data_component (expr);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
se.want_pointer = 1;
|
se.want_pointer = 1;
|
se.descriptor_only = 1;
|
se.descriptor_only = 1;
|
gfc_conv_expr (&se, expr);
|
gfc_conv_expr (&se, expr);
|
|
|
/* Evaluate expr3 just once if not a variable. */
|
/* Evaluate expr3 just once if not a variable. */
|
if (al == code->ext.alloc.list
|
if (al == code->ext.alloc.list
|
&& al->expr->ts.type == BT_CLASS
|
&& al->expr->ts.type == BT_CLASS
|
&& code->expr3
|
&& code->expr3
|
&& code->expr3->ts.type == BT_CLASS
|
&& code->expr3->ts.type == BT_CLASS
|
&& code->expr3->expr_type != EXPR_VARIABLE)
|
&& code->expr3->expr_type != EXPR_VARIABLE)
|
{
|
{
|
gfc_init_se (&se_sz, NULL);
|
gfc_init_se (&se_sz, NULL);
|
gfc_conv_expr_reference (&se_sz, code->expr3);
|
gfc_conv_expr_reference (&se_sz, code->expr3);
|
gfc_conv_class_to_class (&se_sz, code->expr3,
|
gfc_conv_class_to_class (&se_sz, code->expr3,
|
code->expr3->ts, false);
|
code->expr3->ts, false);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.post, &se_sz.post);
|
gfc_add_block_to_block (&se.post, &se_sz.post);
|
classexpr = build_fold_indirect_ref_loc (input_location,
|
classexpr = build_fold_indirect_ref_loc (input_location,
|
se_sz.expr);
|
se_sz.expr);
|
classexpr = gfc_evaluate_now (classexpr, &se.pre);
|
classexpr = gfc_evaluate_now (classexpr, &se.pre);
|
memsize = gfc_vtable_size_get (classexpr);
|
memsize = gfc_vtable_size_get (classexpr);
|
memsize = fold_convert (sizetype, memsize);
|
memsize = fold_convert (sizetype, memsize);
|
}
|
}
|
|
|
memsz = memsize;
|
memsz = memsize;
|
class_expr = classexpr;
|
class_expr = classexpr;
|
|
|
nelems = NULL_TREE;
|
nelems = NULL_TREE;
|
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
|
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
|
memsz, &nelems, code->expr3))
|
memsz, &nelems, code->expr3))
|
{
|
{
|
/* A scalar or derived type. */
|
/* A scalar or derived type. */
|
|
|
/* Determine allocate size. */
|
/* Determine allocate size. */
|
if (al->expr->ts.type == BT_CLASS
|
if (al->expr->ts.type == BT_CLASS
|
&& code->expr3
|
&& code->expr3
|
&& memsz == NULL_TREE)
|
&& memsz == NULL_TREE)
|
{
|
{
|
if (code->expr3->ts.type == BT_CLASS)
|
if (code->expr3->ts.type == BT_CLASS)
|
{
|
{
|
sz = gfc_copy_expr (code->expr3);
|
sz = gfc_copy_expr (code->expr3);
|
gfc_add_vptr_component (sz);
|
gfc_add_vptr_component (sz);
|
gfc_add_size_component (sz);
|
gfc_add_size_component (sz);
|
gfc_init_se (&se_sz, NULL);
|
gfc_init_se (&se_sz, NULL);
|
gfc_conv_expr (&se_sz, sz);
|
gfc_conv_expr (&se_sz, sz);
|
gfc_free_expr (sz);
|
gfc_free_expr (sz);
|
memsz = se_sz.expr;
|
memsz = se_sz.expr;
|
}
|
}
|
else
|
else
|
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
|
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
|
}
|
}
|
else if (al->expr->ts.type == BT_CHARACTER
|
else if (al->expr->ts.type == BT_CHARACTER
|
&& al->expr->ts.deferred && code->expr3)
|
&& al->expr->ts.deferred && code->expr3)
|
{
|
{
|
if (!code->expr3->ts.u.cl->backend_decl)
|
if (!code->expr3->ts.u.cl->backend_decl)
|
{
|
{
|
/* Convert and use the length expression. */
|
/* Convert and use the length expression. */
|
gfc_init_se (&se_sz, NULL);
|
gfc_init_se (&se_sz, NULL);
|
if (code->expr3->expr_type == EXPR_VARIABLE
|
if (code->expr3->expr_type == EXPR_VARIABLE
|
|| code->expr3->expr_type == EXPR_CONSTANT)
|
|| code->expr3->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_conv_expr (&se_sz, code->expr3);
|
gfc_conv_expr (&se_sz, code->expr3);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
se_sz.string_length
|
se_sz.string_length
|
= gfc_evaluate_now (se_sz.string_length, &se.pre);
|
= gfc_evaluate_now (se_sz.string_length, &se.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
memsz = se_sz.string_length;
|
memsz = se_sz.string_length;
|
}
|
}
|
else if (code->expr3->mold
|
else if (code->expr3->mold
|
&& code->expr3->ts.u.cl
|
&& code->expr3->ts.u.cl
|
&& code->expr3->ts.u.cl->length)
|
&& code->expr3->ts.u.cl->length)
|
{
|
{
|
gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
|
gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
|
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
memsz = se_sz.expr;
|
memsz = se_sz.expr;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* This is would be inefficient and possibly could
|
/* This is would be inefficient and possibly could
|
generate wrong code if the result were not stored
|
generate wrong code if the result were not stored
|
in expr3/slen3. */
|
in expr3/slen3. */
|
if (slen3 == NULL_TREE)
|
if (slen3 == NULL_TREE)
|
{
|
{
|
gfc_conv_expr (&se_sz, code->expr3);
|
gfc_conv_expr (&se_sz, code->expr3);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
|
expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
|
gfc_add_block_to_block (&post, &se_sz.post);
|
gfc_add_block_to_block (&post, &se_sz.post);
|
slen3 = gfc_evaluate_now (se_sz.string_length,
|
slen3 = gfc_evaluate_now (se_sz.string_length,
|
&se.pre);
|
&se.pre);
|
}
|
}
|
memsz = slen3;
|
memsz = slen3;
|
}
|
}
|
}
|
}
|
else
|
else
|
/* Otherwise use the stored string length. */
|
/* Otherwise use the stored string length. */
|
memsz = code->expr3->ts.u.cl->backend_decl;
|
memsz = code->expr3->ts.u.cl->backend_decl;
|
tmp = al->expr->ts.u.cl->backend_decl;
|
tmp = al->expr->ts.u.cl->backend_decl;
|
|
|
/* Store the string length. */
|
/* Store the string length. */
|
if (tmp && TREE_CODE (tmp) == VAR_DECL)
|
if (tmp && TREE_CODE (tmp) == VAR_DECL)
|
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
|
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
|
memsz));
|
memsz));
|
|
|
/* Convert to size in bytes, using the character KIND. */
|
/* Convert to size in bytes, using the character KIND. */
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
|
tmp = TYPE_SIZE_UNIT (tmp);
|
tmp = TYPE_SIZE_UNIT (tmp);
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
TREE_TYPE (tmp), tmp,
|
TREE_TYPE (tmp), tmp,
|
fold_convert (TREE_TYPE (tmp), memsz));
|
fold_convert (TREE_TYPE (tmp), memsz));
|
}
|
}
|
else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
|
else if (al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
|
{
|
{
|
gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
|
gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
|
gfc_init_se (&se_sz, NULL);
|
gfc_init_se (&se_sz, NULL);
|
gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
|
gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.pre);
|
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
|
se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
gfc_add_block_to_block (&se.pre, &se_sz.post);
|
/* Store the string length. */
|
/* Store the string length. */
|
tmp = al->expr->ts.u.cl->backend_decl;
|
tmp = al->expr->ts.u.cl->backend_decl;
|
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
|
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
|
se_sz.expr));
|
se_sz.expr));
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
tmp = TYPE_SIZE_UNIT (tmp);
|
tmp = TYPE_SIZE_UNIT (tmp);
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
TREE_TYPE (tmp), tmp,
|
TREE_TYPE (tmp), tmp,
|
fold_convert (TREE_TYPE (se_sz.expr),
|
fold_convert (TREE_TYPE (se_sz.expr),
|
se_sz.expr));
|
se_sz.expr));
|
}
|
}
|
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
|
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
|
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
else if (memsz == NULL_TREE)
|
else if (memsz == NULL_TREE)
|
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
|
memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
|
|
|
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
|
if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
|
{
|
{
|
memsz = se.string_length;
|
memsz = se.string_length;
|
|
|
/* Convert to size in bytes, using the character KIND. */
|
/* Convert to size in bytes, using the character KIND. */
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
|
tmp = TYPE_SIZE_UNIT (tmp);
|
tmp = TYPE_SIZE_UNIT (tmp);
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
memsz = fold_build2_loc (input_location, MULT_EXPR,
|
TREE_TYPE (tmp), tmp,
|
TREE_TYPE (tmp), tmp,
|
fold_convert (TREE_TYPE (tmp), memsz));
|
fold_convert (TREE_TYPE (tmp), memsz));
|
}
|
}
|
|
|
/* Allocate - for non-pointers with re-alloc checking. */
|
/* Allocate - for non-pointers with re-alloc checking. */
|
if (gfc_expr_attr (expr).allocatable)
|
if (gfc_expr_attr (expr).allocatable)
|
gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
|
gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
|
stat, errmsg, errlen, label_finish, expr);
|
stat, errmsg, errlen, label_finish, expr);
|
else
|
else
|
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
|
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
|
|
|
if (al->expr->ts.type == BT_DERIVED
|
if (al->expr->ts.type == BT_DERIVED
|
&& expr->ts.u.derived->attr.alloc_comp)
|
&& expr->ts.u.derived->attr.alloc_comp)
|
{
|
{
|
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
|
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
|
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
|
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
else if (al->expr->ts.type == BT_CLASS)
|
else if (al->expr->ts.type == BT_CLASS)
|
{
|
{
|
/* With class objects, it is best to play safe and null the
|
/* With class objects, it is best to play safe and null the
|
memory because we cannot know if dynamic types have allocatable
|
memory because we cannot know if dynamic types have allocatable
|
components or not. */
|
components or not. */
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
builtin_decl_explicit (BUILT_IN_MEMSET),
|
builtin_decl_explicit (BUILT_IN_MEMSET),
|
3, se.expr, integer_zero_node, memsz);
|
3, se.expr, integer_zero_node, memsz);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
}
|
}
|
|
|
gfc_add_block_to_block (&block, &se.pre);
|
gfc_add_block_to_block (&block, &se.pre);
|
|
|
/* Error checking -- Note: ERRMSG only makes sense with STAT. */
|
/* Error checking -- Note: ERRMSG only makes sense with STAT. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
tmp = build1_v (GOTO_EXPR, label_errmsg);
|
tmp = build1_v (GOTO_EXPR, label_errmsg);
|
parm = fold_build2_loc (input_location, NE_EXPR,
|
parm = fold_build2_loc (input_location, NE_EXPR,
|
boolean_type_node, stat,
|
boolean_type_node, stat,
|
build_int_cst (TREE_TYPE (stat), 0));
|
build_int_cst (TREE_TYPE (stat), 0));
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
gfc_unlikely (parm), tmp,
|
gfc_unlikely (parm), tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* We need the vptr of CLASS objects to be initialized. */
|
/* We need the vptr of CLASS objects to be initialized. */
|
e = gfc_copy_expr (al->expr);
|
e = gfc_copy_expr (al->expr);
|
if (e->ts.type == BT_CLASS)
|
if (e->ts.type == BT_CLASS)
|
{
|
{
|
gfc_expr *lhs, *rhs;
|
gfc_expr *lhs, *rhs;
|
gfc_se lse;
|
gfc_se lse;
|
|
|
lhs = gfc_expr_to_initialize (e);
|
lhs = gfc_expr_to_initialize (e);
|
gfc_add_vptr_component (lhs);
|
gfc_add_vptr_component (lhs);
|
|
|
if (class_expr != NULL_TREE)
|
if (class_expr != NULL_TREE)
|
{
|
{
|
/* Polymorphic SOURCE: VPTR must be determined at run time. */
|
/* Polymorphic SOURCE: VPTR must be determined at run time. */
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
lse.want_pointer = 1;
|
lse.want_pointer = 1;
|
gfc_conv_expr (&lse, lhs);
|
gfc_conv_expr (&lse, lhs);
|
tmp = gfc_class_vptr_get (class_expr);
|
tmp = gfc_class_vptr_get (class_expr);
|
gfc_add_modify (&block, lse.expr,
|
gfc_add_modify (&block, lse.expr,
|
fold_convert (TREE_TYPE (lse.expr), tmp));
|
fold_convert (TREE_TYPE (lse.expr), tmp));
|
}
|
}
|
else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
|
else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
|
{
|
{
|
/* Polymorphic SOURCE: VPTR must be determined at run time. */
|
/* Polymorphic SOURCE: VPTR must be determined at run time. */
|
rhs = gfc_copy_expr (code->expr3);
|
rhs = gfc_copy_expr (code->expr3);
|
gfc_add_vptr_component (rhs);
|
gfc_add_vptr_component (rhs);
|
tmp = gfc_trans_pointer_assignment (lhs, rhs);
|
tmp = gfc_trans_pointer_assignment (lhs, rhs);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_free_expr (rhs);
|
gfc_free_expr (rhs);
|
rhs = gfc_expr_to_initialize (e);
|
rhs = gfc_expr_to_initialize (e);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* VPTR is fixed at compile time. */
|
/* VPTR is fixed at compile time. */
|
gfc_symbol *vtab;
|
gfc_symbol *vtab;
|
gfc_typespec *ts;
|
gfc_typespec *ts;
|
if (code->expr3)
|
if (code->expr3)
|
ts = &code->expr3->ts;
|
ts = &code->expr3->ts;
|
else if (e->ts.type == BT_DERIVED)
|
else if (e->ts.type == BT_DERIVED)
|
ts = &e->ts;
|
ts = &e->ts;
|
else if (code->ext.alloc.ts.type == BT_DERIVED)
|
else if (code->ext.alloc.ts.type == BT_DERIVED)
|
ts = &code->ext.alloc.ts;
|
ts = &code->ext.alloc.ts;
|
else if (e->ts.type == BT_CLASS)
|
else if (e->ts.type == BT_CLASS)
|
ts = &CLASS_DATA (e)->ts;
|
ts = &CLASS_DATA (e)->ts;
|
else
|
else
|
ts = &e->ts;
|
ts = &e->ts;
|
|
|
if (ts->type == BT_DERIVED)
|
if (ts->type == BT_DERIVED)
|
{
|
{
|
vtab = gfc_find_derived_vtab (ts->u.derived);
|
vtab = gfc_find_derived_vtab (ts->u.derived);
|
gcc_assert (vtab);
|
gcc_assert (vtab);
|
gfc_init_se (&lse, NULL);
|
gfc_init_se (&lse, NULL);
|
lse.want_pointer = 1;
|
lse.want_pointer = 1;
|
gfc_conv_expr (&lse, lhs);
|
gfc_conv_expr (&lse, lhs);
|
tmp = gfc_build_addr_expr (NULL_TREE,
|
tmp = gfc_build_addr_expr (NULL_TREE,
|
gfc_get_symbol_decl (vtab));
|
gfc_get_symbol_decl (vtab));
|
gfc_add_modify (&block, lse.expr,
|
gfc_add_modify (&block, lse.expr,
|
fold_convert (TREE_TYPE (lse.expr), tmp));
|
fold_convert (TREE_TYPE (lse.expr), tmp));
|
}
|
}
|
}
|
}
|
gfc_free_expr (lhs);
|
gfc_free_expr (lhs);
|
}
|
}
|
|
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
if (code->expr3 && !code->expr3->mold)
|
if (code->expr3 && !code->expr3->mold)
|
{
|
{
|
/* Initialization via SOURCE block
|
/* Initialization via SOURCE block
|
(or static default initializer). */
|
(or static default initializer). */
|
gfc_expr *rhs = gfc_copy_expr (code->expr3);
|
gfc_expr *rhs = gfc_copy_expr (code->expr3);
|
if (class_expr != NULL_TREE)
|
if (class_expr != NULL_TREE)
|
{
|
{
|
tree to;
|
tree to;
|
to = TREE_OPERAND (se.expr, 0);
|
to = TREE_OPERAND (se.expr, 0);
|
|
|
tmp = gfc_copy_class_to_class (class_expr, to, nelems);
|
tmp = gfc_copy_class_to_class (class_expr, to, nelems);
|
}
|
}
|
else if (al->expr->ts.type == BT_CLASS)
|
else if (al->expr->ts.type == BT_CLASS)
|
{
|
{
|
gfc_actual_arglist *actual;
|
gfc_actual_arglist *actual;
|
gfc_expr *ppc;
|
gfc_expr *ppc;
|
gfc_code *ppc_code;
|
gfc_code *ppc_code;
|
gfc_ref *dataref;
|
gfc_ref *dataref;
|
|
|
/* Do a polymorphic deep copy. */
|
/* Do a polymorphic deep copy. */
|
actual = gfc_get_actual_arglist ();
|
actual = gfc_get_actual_arglist ();
|
actual->expr = gfc_copy_expr (rhs);
|
actual->expr = gfc_copy_expr (rhs);
|
if (rhs->ts.type == BT_CLASS)
|
if (rhs->ts.type == BT_CLASS)
|
gfc_add_data_component (actual->expr);
|
gfc_add_data_component (actual->expr);
|
actual->next = gfc_get_actual_arglist ();
|
actual->next = gfc_get_actual_arglist ();
|
actual->next->expr = gfc_copy_expr (al->expr);
|
actual->next->expr = gfc_copy_expr (al->expr);
|
actual->next->expr->ts.type = BT_CLASS;
|
actual->next->expr->ts.type = BT_CLASS;
|
gfc_add_data_component (actual->next->expr);
|
gfc_add_data_component (actual->next->expr);
|
|
|
dataref = actual->next->expr->ref;
|
dataref = actual->next->expr->ref;
|
/* Make sure we go up through the reference chain to
|
/* Make sure we go up through the reference chain to
|
the _data reference, where the arrayspec is found. */
|
the _data reference, where the arrayspec is found. */
|
while (dataref->next && dataref->next->type != REF_ARRAY)
|
while (dataref->next && dataref->next->type != REF_ARRAY)
|
dataref = dataref->next;
|
dataref = dataref->next;
|
|
|
if (dataref->u.c.component->as)
|
if (dataref->u.c.component->as)
|
{
|
{
|
int dim;
|
int dim;
|
gfc_expr *temp;
|
gfc_expr *temp;
|
gfc_ref *ref = dataref->next;
|
gfc_ref *ref = dataref->next;
|
ref->u.ar.type = AR_SECTION;
|
ref->u.ar.type = AR_SECTION;
|
/* We have to set up the array reference to give ranges
|
/* We have to set up the array reference to give ranges
|
in all dimensions and ensure that the end and stride
|
in all dimensions and ensure that the end and stride
|
are set so that the copy can be scalarized. */
|
are set so that the copy can be scalarized. */
|
dim = 0;
|
dim = 0;
|
for (; dim < dataref->u.c.component->as->rank; dim++)
|
for (; dim < dataref->u.c.component->as->rank; dim++)
|
{
|
{
|
ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
|
ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
|
if (ref->u.ar.end[dim] == NULL)
|
if (ref->u.ar.end[dim] == NULL)
|
{
|
{
|
ref->u.ar.end[dim] = ref->u.ar.start[dim];
|
ref->u.ar.end[dim] = ref->u.ar.start[dim];
|
temp = gfc_get_int_expr (gfc_default_integer_kind,
|
temp = gfc_get_int_expr (gfc_default_integer_kind,
|
&al->expr->where, 1);
|
&al->expr->where, 1);
|
ref->u.ar.start[dim] = temp;
|
ref->u.ar.start[dim] = temp;
|
}
|
}
|
temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
|
temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
|
gfc_copy_expr (ref->u.ar.start[dim]));
|
gfc_copy_expr (ref->u.ar.start[dim]));
|
temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
|
temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
|
&al->expr->where, 1),
|
&al->expr->where, 1),
|
temp);
|
temp);
|
}
|
}
|
}
|
}
|
if (rhs->ts.type == BT_CLASS)
|
if (rhs->ts.type == BT_CLASS)
|
{
|
{
|
ppc = gfc_copy_expr (rhs);
|
ppc = gfc_copy_expr (rhs);
|
gfc_add_vptr_component (ppc);
|
gfc_add_vptr_component (ppc);
|
}
|
}
|
else
|
else
|
ppc = gfc_lval_expr_from_sym
|
ppc = gfc_lval_expr_from_sym
|
(gfc_find_derived_vtab (rhs->ts.u.derived));
|
(gfc_find_derived_vtab (rhs->ts.u.derived));
|
gfc_add_component_ref (ppc, "_copy");
|
gfc_add_component_ref (ppc, "_copy");
|
|
|
ppc_code = gfc_get_code ();
|
ppc_code = gfc_get_code ();
|
ppc_code->resolved_sym = ppc->symtree->n.sym;
|
ppc_code->resolved_sym = ppc->symtree->n.sym;
|
/* Although '_copy' is set to be elemental in class.c, it is
|
/* Although '_copy' is set to be elemental in class.c, it is
|
not staying that way. Find out why, sometime.... */
|
not staying that way. Find out why, sometime.... */
|
ppc_code->resolved_sym->attr.elemental = 1;
|
ppc_code->resolved_sym->attr.elemental = 1;
|
ppc_code->ext.actual = actual;
|
ppc_code->ext.actual = actual;
|
ppc_code->expr1 = ppc;
|
ppc_code->expr1 = ppc;
|
ppc_code->op = EXEC_CALL;
|
ppc_code->op = EXEC_CALL;
|
/* Since '_copy' is elemental, the scalarizer will take care
|
/* Since '_copy' is elemental, the scalarizer will take care
|
of arrays in gfc_trans_call. */
|
of arrays in gfc_trans_call. */
|
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
|
tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
|
gfc_free_statements (ppc_code);
|
gfc_free_statements (ppc_code);
|
}
|
}
|
else if (expr3 != NULL_TREE)
|
else if (expr3 != NULL_TREE)
|
{
|
{
|
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
|
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
|
gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
|
gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
|
slen3, expr3, code->expr3->ts.kind);
|
slen3, expr3, code->expr3->ts.kind);
|
tmp = NULL_TREE;
|
tmp = NULL_TREE;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Switch off automatic reallocation since we have just done
|
/* Switch off automatic reallocation since we have just done
|
the ALLOCATE. */
|
the ALLOCATE. */
|
int realloc_lhs = gfc_option.flag_realloc_lhs;
|
int realloc_lhs = gfc_option.flag_realloc_lhs;
|
gfc_option.flag_realloc_lhs = 0;
|
gfc_option.flag_realloc_lhs = 0;
|
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
|
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
|
rhs, false, false);
|
rhs, false, false);
|
gfc_option.flag_realloc_lhs = realloc_lhs;
|
gfc_option.flag_realloc_lhs = realloc_lhs;
|
}
|
}
|
gfc_free_expr (rhs);
|
gfc_free_expr (rhs);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
else if (code->expr3 && code->expr3->mold
|
else if (code->expr3 && code->expr3->mold
|
&& code->expr3->ts.type == BT_CLASS)
|
&& code->expr3->ts.type == BT_CLASS)
|
{
|
{
|
/* Since the _vptr has already been assigned to the allocate
|
/* Since the _vptr has already been assigned to the allocate
|
object, we can use gfc_copy_class_to_class in its
|
object, we can use gfc_copy_class_to_class in its
|
initialization mode. */
|
initialization mode. */
|
tmp = TREE_OPERAND (se.expr, 0);
|
tmp = TREE_OPERAND (se.expr, 0);
|
tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
|
tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
gfc_free_expr (expr);
|
gfc_free_expr (expr);
|
}
|
}
|
|
|
/* STAT. */
|
/* STAT. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, label_errmsg);
|
tmp = build1_v (LABEL_EXPR, label_errmsg);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* ERRMSG - only useful if STAT is present. */
|
/* ERRMSG - only useful if STAT is present. */
|
if (code->expr1 && code->expr2)
|
if (code->expr1 && code->expr2)
|
{
|
{
|
const char *msg = "Attempt to allocate an allocated object";
|
const char *msg = "Attempt to allocate an allocated object";
|
tree slen, dlen, errmsg_str;
|
tree slen, dlen, errmsg_str;
|
stmtblock_t errmsg_block;
|
stmtblock_t errmsg_block;
|
|
|
gfc_init_block (&errmsg_block);
|
gfc_init_block (&errmsg_block);
|
|
|
errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
|
errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
|
gfc_add_modify (&errmsg_block, errmsg_str,
|
gfc_add_modify (&errmsg_block, errmsg_str,
|
gfc_build_addr_expr (pchar_type_node,
|
gfc_build_addr_expr (pchar_type_node,
|
gfc_build_localized_cstring_const (msg)));
|
gfc_build_localized_cstring_const (msg)));
|
|
|
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
|
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
|
dlen = gfc_get_expr_charlen (code->expr2);
|
dlen = gfc_get_expr_charlen (code->expr2);
|
slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
|
slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
|
slen);
|
slen);
|
|
|
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
|
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
|
slen, errmsg_str, gfc_default_character_kind);
|
slen, errmsg_str, gfc_default_character_kind);
|
dlen = gfc_finish_block (&errmsg_block);
|
dlen = gfc_finish_block (&errmsg_block);
|
|
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
build_int_cst (TREE_TYPE (stat), 0));
|
build_int_cst (TREE_TYPE (stat), 0));
|
|
|
tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
|
tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* STAT block. */
|
/* STAT block. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
if (TREE_USED (label_finish))
|
if (TREE_USED (label_finish))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, label_finish);
|
tmp = build1_v (LABEL_EXPR, label_finish);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_lhs (&se, code->expr1);
|
gfc_conv_expr_lhs (&se, code->expr1);
|
tmp = convert (TREE_TYPE (se.expr), stat);
|
tmp = convert (TREE_TYPE (se.expr), stat);
|
gfc_add_modify (&block, se.expr, tmp);
|
gfc_add_modify (&block, se.expr, tmp);
|
}
|
}
|
|
|
gfc_add_block_to_block (&block, &se.post);
|
gfc_add_block_to_block (&block, &se.post);
|
gfc_add_block_to_block (&block, &post);
|
gfc_add_block_to_block (&block, &post);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate a DEALLOCATE statement. */
|
/* Translate a DEALLOCATE statement. */
|
|
|
tree
|
tree
|
gfc_trans_deallocate (gfc_code *code)
|
gfc_trans_deallocate (gfc_code *code)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
gfc_alloc *al;
|
gfc_alloc *al;
|
tree apstat, pstat, stat, errmsg, errlen, tmp;
|
tree apstat, pstat, stat, errmsg, errlen, tmp;
|
tree label_finish, label_errmsg;
|
tree label_finish, label_errmsg;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
|
pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
|
label_finish = label_errmsg = NULL_TREE;
|
label_finish = label_errmsg = NULL_TREE;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
/* Count the number of failed deallocations. If deallocate() was
|
/* Count the number of failed deallocations. If deallocate() was
|
called with STAT= , then set STAT to the count. If deallocate
|
called with STAT= , then set STAT to the count. If deallocate
|
was called with ERRMSG, then set ERRMG to a string. */
|
was called with ERRMSG, then set ERRMG to a string. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
tree gfc_int4_type_node = gfc_get_int_type (4);
|
|
|
stat = gfc_create_var (gfc_int4_type_node, "stat");
|
stat = gfc_create_var (gfc_int4_type_node, "stat");
|
pstat = gfc_build_addr_expr (NULL_TREE, stat);
|
pstat = gfc_build_addr_expr (NULL_TREE, stat);
|
|
|
/* GOTO destinations. */
|
/* GOTO destinations. */
|
label_errmsg = gfc_build_label_decl (NULL_TREE);
|
label_errmsg = gfc_build_label_decl (NULL_TREE);
|
label_finish = gfc_build_label_decl (NULL_TREE);
|
label_finish = gfc_build_label_decl (NULL_TREE);
|
TREE_USED (label_finish) = 0;
|
TREE_USED (label_finish) = 0;
|
}
|
}
|
|
|
/* Set ERRMSG - only needed if STAT is available. */
|
/* Set ERRMSG - only needed if STAT is available. */
|
if (code->expr1 && code->expr2)
|
if (code->expr1 && code->expr2)
|
{
|
{
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
se.want_pointer = 1;
|
se.want_pointer = 1;
|
gfc_conv_expr_lhs (&se, code->expr2);
|
gfc_conv_expr_lhs (&se, code->expr2);
|
errmsg = se.expr;
|
errmsg = se.expr;
|
errlen = se.string_length;
|
errlen = se.string_length;
|
}
|
}
|
|
|
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
for (al = code->ext.alloc.list; al != NULL; al = al->next)
|
{
|
{
|
gfc_expr *expr = gfc_copy_expr (al->expr);
|
gfc_expr *expr = gfc_copy_expr (al->expr);
|
gcc_assert (expr->expr_type == EXPR_VARIABLE);
|
gcc_assert (expr->expr_type == EXPR_VARIABLE);
|
|
|
if (expr->ts.type == BT_CLASS)
|
if (expr->ts.type == BT_CLASS)
|
gfc_add_data_component (expr);
|
gfc_add_data_component (expr);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_start_block (&se.pre);
|
gfc_start_block (&se.pre);
|
|
|
se.want_pointer = 1;
|
se.want_pointer = 1;
|
se.descriptor_only = 1;
|
se.descriptor_only = 1;
|
gfc_conv_expr (&se, expr);
|
gfc_conv_expr (&se, expr);
|
|
|
if (expr->rank || gfc_is_coarray (expr))
|
if (expr->rank || gfc_is_coarray (expr))
|
{
|
{
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
|
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_ref *last = NULL;
|
gfc_ref *last = NULL;
|
for (ref = expr->ref; ref; ref = ref->next)
|
for (ref = expr->ref; ref; ref = ref->next)
|
if (ref->type == REF_COMPONENT)
|
if (ref->type == REF_COMPONENT)
|
last = ref;
|
last = ref;
|
|
|
/* Do not deallocate the components of a derived type
|
/* Do not deallocate the components of a derived type
|
ultimate pointer component. */
|
ultimate pointer component. */
|
if (!(last && last->u.c.component->attr.pointer)
|
if (!(last && last->u.c.component->attr.pointer)
|
&& !(!last && expr->symtree->n.sym->attr.pointer))
|
&& !(!last && expr->symtree->n.sym->attr.pointer))
|
{
|
{
|
tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
|
tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
|
expr->rank);
|
expr->rank);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
}
|
}
|
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
|
tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
|
label_finish, expr);
|
label_finish, expr);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
|
tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
|
expr, expr->ts);
|
expr, expr->ts);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
/* Set to zero after deallocation. */
|
/* Set to zero after deallocation. */
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
|
se.expr,
|
se.expr,
|
build_int_cst (TREE_TYPE (se.expr), 0));
|
build_int_cst (TREE_TYPE (se.expr), 0));
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
|
|
if (al->expr->ts.type == BT_CLASS)
|
if (al->expr->ts.type == BT_CLASS)
|
{
|
{
|
/* Reset _vptr component to declared type. */
|
/* Reset _vptr component to declared type. */
|
gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
|
gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr);
|
gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
|
gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived);
|
gfc_add_vptr_component (lhs);
|
gfc_add_vptr_component (lhs);
|
rhs = gfc_lval_expr_from_sym (vtab);
|
rhs = gfc_lval_expr_from_sym (vtab);
|
tmp = gfc_trans_pointer_assignment (lhs, rhs);
|
tmp = gfc_trans_pointer_assignment (lhs, rhs);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_free_expr (lhs);
|
gfc_free_expr (lhs);
|
gfc_free_expr (rhs);
|
gfc_free_expr (rhs);
|
}
|
}
|
}
|
}
|
|
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
tree cond;
|
tree cond;
|
|
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
build_int_cst (TREE_TYPE (stat), 0));
|
build_int_cst (TREE_TYPE (stat), 0));
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
gfc_unlikely (cond),
|
gfc_unlikely (cond),
|
build1_v (GOTO_EXPR, label_errmsg),
|
build1_v (GOTO_EXPR, label_errmsg),
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
gfc_add_expr_to_block (&se.pre, tmp);
|
gfc_add_expr_to_block (&se.pre, tmp);
|
}
|
}
|
|
|
tmp = gfc_finish_block (&se.pre);
|
tmp = gfc_finish_block (&se.pre);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_free_expr (expr);
|
gfc_free_expr (expr);
|
}
|
}
|
|
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, label_errmsg);
|
tmp = build1_v (LABEL_EXPR, label_errmsg);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* Set ERRMSG - only needed if STAT is available. */
|
/* Set ERRMSG - only needed if STAT is available. */
|
if (code->expr1 && code->expr2)
|
if (code->expr1 && code->expr2)
|
{
|
{
|
const char *msg = "Attempt to deallocate an unallocated object";
|
const char *msg = "Attempt to deallocate an unallocated object";
|
stmtblock_t errmsg_block;
|
stmtblock_t errmsg_block;
|
tree errmsg_str, slen, dlen, cond;
|
tree errmsg_str, slen, dlen, cond;
|
|
|
gfc_init_block (&errmsg_block);
|
gfc_init_block (&errmsg_block);
|
|
|
errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
|
errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
|
gfc_add_modify (&errmsg_block, errmsg_str,
|
gfc_add_modify (&errmsg_block, errmsg_str,
|
gfc_build_addr_expr (pchar_type_node,
|
gfc_build_addr_expr (pchar_type_node,
|
gfc_build_localized_cstring_const (msg)));
|
gfc_build_localized_cstring_const (msg)));
|
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
|
slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
|
dlen = gfc_get_expr_charlen (code->expr2);
|
dlen = gfc_get_expr_charlen (code->expr2);
|
|
|
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
|
gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
|
slen, errmsg_str, gfc_default_character_kind);
|
slen, errmsg_str, gfc_default_character_kind);
|
tmp = gfc_finish_block (&errmsg_block);
|
tmp = gfc_finish_block (&errmsg_block);
|
|
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
|
build_int_cst (TREE_TYPE (stat), 0));
|
build_int_cst (TREE_TYPE (stat), 0));
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
gfc_unlikely (cond), tmp,
|
gfc_unlikely (cond), tmp,
|
build_empty_stmt (input_location));
|
build_empty_stmt (input_location));
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
if (code->expr1 && TREE_USED (label_finish))
|
if (code->expr1 && TREE_USED (label_finish))
|
{
|
{
|
tmp = build1_v (LABEL_EXPR, label_finish);
|
tmp = build1_v (LABEL_EXPR, label_finish);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
}
|
}
|
|
|
/* Set STAT. */
|
/* Set STAT. */
|
if (code->expr1)
|
if (code->expr1)
|
{
|
{
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_lhs (&se, code->expr1);
|
gfc_conv_expr_lhs (&se, code->expr1);
|
tmp = convert (TREE_TYPE (se.expr), stat);
|
tmp = convert (TREE_TYPE (se.expr), stat);
|
gfc_add_modify (&block, se.expr, tmp);
|
gfc_add_modify (&block, se.expr, tmp);
|
}
|
}
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
#include "gt-fortran-trans-stmt.h"
|
#include "gt-fortran-trans-stmt.h"
|
|
|
