/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+ 2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
{
gfc_ref *ref;
- ss = gfc_get_array_ss (gfc_ss_terminator, e, 0, GFC_SS_SECTION);
-
ref = e->ref;
while (ref)
{
}
gcc_assert (ref != NULL);
- ref->u.ar.type = AR_FULL;
- ss->data.info.ref = ref;
+ if (ref->u.ar.type == AR_ELEMENT)
+ ref->u.ar.type = AR_SECTION;
+ ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
}
return ss;
/* Argument-free version: THIS_IMAGE(). */
if (expr->value.function.actual->expr == NULL)
{
- se->expr = gfort_gvar_caf_this_image;
+ se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+ gfort_gvar_caf_this_image);
return;
}
gcc_assert (!expr->value.function.actual->next->expr);
gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
dim_arg = se->loop->loopvar[0];
dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
/* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
one always has a dim_arg argument.
- m = this_images() - 1
+ m = this_image() - 1
+ if (corank == 1)
+ {
+ sub(1) = m + lcobound(corank)
+ return;
+ }
i = rank
min_var = min (rank + corank - 2, rank + dim_arg - 1)
for (;;)
: m + lcobound(corank)
*/
+ /* this_image () - 1. */
+ tmp = fold_convert (type, gfort_gvar_caf_this_image);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+ build_int_cst (type, 1));
+ if (corank == 1)
+ {
+ /* sub(1) = m + lcobound(corank). */
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ build_int_cst (TREE_TYPE (gfc_array_index_type),
+ corank+rank-1));
+ lbound = fold_convert (type, lbound);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+ se->expr = tmp;
+ return;
+ }
+
m = gfc_create_var (type, NULL);
ml = gfc_create_var (type, NULL);
loop_var = gfc_create_var (integer_type_node, NULL);
min_var = gfc_create_var (integer_type_node, NULL);
/* m = this_image () - 1. */
- tmp = fold_convert (type, gfort_gvar_caf_this_image);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
- build_int_cst (type, 1));
gfc_add_modify (&se->pre, m, tmp);
/* min_var = min (rank + corank-2, rank + dim_arg - 1). */
else
{
gfc_init_coarray_decl (false);
- num_images = gfort_gvar_caf_num_images;
+ num_images = fold_convert (type, gfort_gvar_caf_num_images);
}
tmp = gfc_create_var (type, NULL);
trans_num_images (gfc_se * se)
{
gfc_init_coarray_decl (false);
- se->expr = gfort_gvar_caf_num_images;
+ se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+ gfort_gvar_caf_num_images);
}
/* Create an implicit second parameter from the loop variable. */
gcc_assert (!arg2->expr);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
gfc_advance_se_ss_chain (se);
bound = se->loop->loopvar[0];
bound = fold_build2_loc (input_location, MINUS_EXPR,
gcc_assert (!arg2->expr);
gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
- gcc_assert (se->ss->expr == expr);
+ gcc_assert (se->ss->info->expr == expr);
bound = se->loop->loopvar[0];
bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
- gfort_gvar_caf_num_images,
+ fold_convert (gfc_array_index_type,
+ gfort_gvar_caf_num_images),
build_int_cst (gfc_array_index_type, 1));
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
gfc_array_index_type, tmp,
gfc_init_coarray_decl (false);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
- gfort_gvar_caf_num_images,
+ fold_convert (gfc_array_index_type,
+ gfort_gvar_caf_num_images),
build_int_cst (gfc_array_index_type, 1));
resbound = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, resbound, tmp);
gfc_symbol *sym;
VEC(tree,gc) *append_args;
- gcc_assert (!se->ss || se->ss->expr == expr);
+ gcc_assert (!se->ss || se->ss->info->expr == expr);
if (se->ss)
gcc_assert (expr->rank > 0);
se->expr = resvar;
}
+
+/* Update given gfc_se to have ss component pointing to the nested gfc_ss
+ struct and return the corresponding loopinfo. */
+
+static gfc_loopinfo *
+enter_nested_loop (gfc_se *se)
+{
+ se->ss = se->ss->nested_ss;
+ gcc_assert (se->ss == se->ss->loop->ss);
+
+ return se->ss->loop;
+}
+
+
/* Inline implementation of the sum and product intrinsics. */
static void
gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
stmtblock_t body;
stmtblock_t block;
tree tmp;
- gfc_loopinfo loop;
- gfc_actual_arglist *actual;
- gfc_ss *arrayss;
- gfc_ss *maskss;
+ gfc_loopinfo loop, *ploop;
+ gfc_actual_arglist *arg_array, *arg_mask;
+ gfc_ss *arrayss = NULL;
+ gfc_ss *maskss = NULL;
gfc_se arrayse;
gfc_se maskse;
+ gfc_se *parent_se;
gfc_expr *arrayexpr;
gfc_expr *maskexpr;
- if (se->ss)
+ if (expr->rank > 0)
{
- gfc_conv_intrinsic_funcall (se, expr);
- return;
+ gcc_assert (gfc_inline_intrinsic_function_p (expr));
+ parent_se = se;
}
+ else
+ parent_se = NULL;
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
gfc_add_modify (&se->pre, resvar, tmp);
- /* Walk the arguments. */
- actual = expr->value.function.actual;
- arrayexpr = actual->expr;
- arrayss = gfc_walk_expr (arrayexpr);
- gcc_assert (arrayss != gfc_ss_terminator);
+ arg_array = expr->value.function.actual;
+
+ arrayexpr = arg_array->expr;
if (op == NE_EXPR || norm2)
/* PARITY and NORM2. */
maskexpr = NULL;
else
{
- actual = actual->next->next;
- gcc_assert (actual);
- maskexpr = actual->expr;
+ arg_mask = arg_array->next->next;
+ gcc_assert (arg_mask != NULL);
+ maskexpr = arg_mask->expr;
}
- if (maskexpr && maskexpr->rank != 0)
+ if (expr->rank == 0)
{
- maskss = gfc_walk_expr (maskexpr);
- gcc_assert (maskss != gfc_ss_terminator);
+ /* Walk the arguments. */
+ arrayss = gfc_walk_expr (arrayexpr);
+ gcc_assert (arrayss != gfc_ss_terminator);
+
+ if (maskexpr && maskexpr->rank > 0)
+ {
+ maskss = gfc_walk_expr (maskexpr);
+ gcc_assert (maskss != gfc_ss_terminator);
+ }
+ else
+ maskss = NULL;
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, arrayss);
+ if (maskexpr && maskexpr->rank > 0)
+ gfc_add_ss_to_loop (&loop, maskss);
+
+ /* Initialize the loop. */
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ gfc_mark_ss_chain_used (arrayss, 1);
+ if (maskexpr && maskexpr->rank > 0)
+ gfc_mark_ss_chain_used (maskss, 1);
+
+ ploop = &loop;
}
else
- maskss = NULL;
+ /* All the work has been done in the parent loops. */
+ ploop = enter_nested_loop (se);
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, arrayss);
- if (maskss)
- gfc_add_ss_to_loop (&loop, maskss);
-
- /* Initialize the loop. */
- gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gcc_assert (ploop);
- gfc_mark_ss_chain_used (arrayss, 1);
- if (maskss)
- gfc_mark_ss_chain_used (maskss, 1);
/* Generate the loop body. */
- gfc_start_scalarized_body (&loop, &body);
+ gfc_start_scalarized_body (ploop, &body);
/* If we have a mask, only add this element if the mask is set. */
- if (maskss)
+ if (maskexpr && maskexpr->rank > 0)
{
- gfc_init_se (&maskse, NULL);
- gfc_copy_loopinfo_to_se (&maskse, &loop);
- maskse.ss = maskss;
+ gfc_init_se (&maskse, parent_se);
+ gfc_copy_loopinfo_to_se (&maskse, ploop);
+ if (expr->rank == 0)
+ maskse.ss = maskss;
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&body, &maskse.pre);
gfc_init_block (&block);
/* Do the actual summation/product. */
- gfc_init_se (&arrayse, NULL);
- gfc_copy_loopinfo_to_se (&arrayse, &loop);
- arrayse.ss = arrayss;
+ gfc_init_se (&arrayse, parent_se);
+ gfc_copy_loopinfo_to_se (&arrayse, ploop);
+ if (expr->rank == 0)
+ arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
gfc_add_block_to_block (&block, &arrayse.post);
- if (maskss)
+ if (maskexpr && maskexpr->rank > 0)
{
/* We enclose the above in if (mask) {...} . */
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&body, tmp);
- gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_trans_scalarizing_loops (ploop, &body);
/* For a scalar mask, enclose the loop in an if statement. */
- if (maskexpr && maskss == NULL)
+ if (maskexpr && maskexpr->rank == 0)
{
- gfc_init_se (&maskse, NULL);
- gfc_conv_expr_val (&maskse, maskexpr);
gfc_init_block (&block);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
+ gfc_add_block_to_block (&block, &ploop->pre);
+ gfc_add_block_to_block (&block, &ploop->post);
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
- build_empty_stmt (input_location));
+ if (expr->rank > 0)
+ {
+ tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
+ build_empty_stmt (input_location));
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ {
+ gcc_assert (expr->rank == 0);
+ gfc_init_se (&maskse, NULL);
+ gfc_conv_expr_val (&maskse, maskexpr);
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ }
+
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
+ gcc_assert (se->post.head == NULL);
}
else
{
- 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, &ploop->pre);
+ gfc_add_block_to_block (&se->pre, &ploop->post);
}
- gfc_cleanup_loop (&loop);
+ if (expr->rank == 0)
+ gfc_cleanup_loop (ploop);
if (norm2)
{
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
+
+ /* The code generated can have more than one loop in sequence (see the
+ comment at the function header). This doesn't work well with the
+ scalarizer, which changes arrays' offset when the scalarization loops
+ are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
+ are currently inlined in the scalar case only (for which loop is of rank
+ one). As there is no dependency to care about in that case, there is no
+ temporary, so that we can use the scalarizer temporary code to handle
+ multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
+ with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
+ to restore offset.
+ TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
+ should eventually go away. We could either create two loops properly,
+ or find another way to save/restore the array offsets between the two
+ loops (without conflicting with temporary management), or use a single
+ loop minmaxloc implementation. See PR 31067. */
+ loop.temp_dim = loop.dimen;
gfc_conv_loop_setup (&loop, &expr->where);
gcc_assert (loop.dimen == 1);
TREE_USED (lab2) = 1;
}
- gfc_mark_ss_chain_used (arrayss, 1);
+ /* An offset must be added to the loop
+ counter to obtain the required position. */
+ gcc_assert (loop.from[0]);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ gfc_add_modify (&loop.pre, offset, tmp);
+
+ gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
if (maskss)
- gfc_mark_ss_chain_used (maskss, 1);
+ gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
/* Assign the value to the limit... */
gfc_add_modify (&ifblock, limit, arrayse.expr);
- /* Remember where we are. An offset must be added to the loop
- counter to obtain the required position. */
- if (loop.from[0])
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
- else
- tmp = gfc_index_one_node;
-
- gfc_add_modify (&block, offset, tmp);
-
if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
{
stmtblock_t ifblock2;
if (lab1)
{
- gfc_trans_scalarized_loop_end (&loop, 0, &body);
+ gfc_trans_scalarized_loop_boundary (&loop, &body);
if (HONOR_NANS (DECL_MODE (limit)))
{
gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
- gfc_start_block (&body);
/* If we have a mask, only check this element if the mask is set. */
if (maskss)
/* Assign the value to the limit... */
gfc_add_modify (&ifblock, limit, arrayse.expr);
- /* Remember where we are. An offset must be added to the loop
- counter to obtain the required position. */
- if (loop.from[0])
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[0]);
- else
- tmp = gfc_index_one_node;
-
- gfc_add_modify (&block, offset, tmp);
-
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
loop.loopvar[0], offset);
gfc_add_modify (&ifblock, pos, tmp);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
+
+ /* The code generated can have more than one loop in sequence (see the
+ comment at the function header). This doesn't work well with the
+ scalarizer, which changes arrays' offset when the scalarization loops
+ are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
+ are currently inlined in the scalar case only. As there is no dependency
+ to care about in that case, there is no temporary, so that we can use the
+ scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
+ here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
+ gfc_trans_scalarized_loop_boundary even later to restore offset.
+ TODO: this prevents inlining of rank > 0 minmaxval calls, so this
+ should eventually go away. We could either create two loops properly,
+ or find another way to save/restore the array offsets between the two
+ loops (without conflicting with temporary management), or use a single
+ loop minmaxval implementation. See PR 31067. */
+ loop.temp_dim = loop.dimen;
gfc_conv_loop_setup (&loop, &expr->where);
if (nonempty == NULL && maskss == NULL
}
}
- gfc_mark_ss_chain_used (arrayss, 1);
+ gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
if (maskss)
- gfc_mark_ss_chain_used (maskss, 1);
+ gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
if (lab)
{
- gfc_trans_scalarized_loop_end (&loop, 0, &body);
+ gfc_trans_scalarized_loop_boundary (&loop, &body);
tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
nan_cst, huge_cst);
gfc_add_modify (&loop.code[0], limit, tmp);
gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
- gfc_start_block (&body);
-
/* If we have a mask, only add this element if the mask is set. */
if (maskss)
{
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
- tree args[2], type, pchartype;
+ tree args[3], type, pchartype;
+ int nargs;
- gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
gfc_init_se (&argse, NULL);
actual = expr->value.function.actual;
+ if (actual->expr->ts.type == BT_CLASS)
+ gfc_add_class_array_ref (actual->expr);
+
ss = gfc_walk_expr (actual->expr);
gcc_assert (ss != gfc_ss_terminator);
argse.want_pointer = 1;
gfc_actual_arglist *arg;
gfc_se argse;
gfc_ss *ss;
- gfc_ss_info *info;
+ gfc_array_info *info;
stmtblock_t block;
int n;
bool scalar_mold;
info = NULL;
if (se->loop)
- info = &se->ss->data.info;
+ info = &se->ss->info->data.array;
/* Convert SOURCE. The output from this stage is:-
source_bytes = length of the source in bytes
source = gfc_conv_descriptor_data_get (argse.expr);
source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
- /* Repack the source if not a full variable array. */
- if (arg->expr->expr_type == EXPR_VARIABLE
- && arg->expr->ref->u.ar.type != AR_FULL)
+ /* Repack the source if not simply contiguous. */
+ if (!gfc_is_simply_contiguous (arg->expr, false))
{
tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
/* Build a destination descriptor, using the pointer, source, as the
data field. */
- gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
- info, mold_type, NULL_TREE, false, true, false,
- &expr->where);
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
+ NULL_TREE, false, true, false, &expr->where);
/* Cast the pointer to the result. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
if (expr->ts.type == BT_CHARACTER)
{
- tree direct;
- tree indirect;
+ tree direct, indirect, free;
ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
tmp = build3_v (COND_EXPR, tmp, direct, indirect);
gfc_add_expr_to_block (&se->pre, tmp);
+ /* Free the temporary string, if necessary. */
+ free = gfc_call_free (tmpdecl);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ dest_word_len, source_bytes);
+ tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
se->expr = tmpdecl;
- se->string_length = dest_word_len;
+ se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
}
else
{
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
+
+ if (arg1->expr->ts.type == BT_CLASS)
+ {
+ /* Make sure that class array expressions have both a _data
+ component reference and an array reference.... */
+ if (CLASS_DATA (arg1->expr)->attr.dimension)
+ gfc_add_class_array_ref (arg1->expr);
+ /* .... whilst scalars only need the _data component. */
+ else
+ gfc_add_data_component (arg1->expr);
+ }
+
ss1 = gfc_walk_expr (arg1->expr);
if (ss1 == gfc_ss_terminator)
{
/* Allocatable scalar. */
arg1se.want_pointer = 1;
- if (arg1->expr->ts.type == BT_CLASS)
- gfc_add_data_component (arg1->expr);
gfc_conv_expr (&arg1se, arg1->expr);
tmp = arg1se.expr;
}
}
-/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
+/* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
static void
gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
build_int_cst (ncopies_type, 0));
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is negative "
- "(its value is %lld)",
+ "(its value is %ld)",
fold_convert (long_integer_type_node, ncopies));
/* If the source length is zero, any non negative value of NCOPIES
break;
case GFC_ISYM_TRANSFER:
- if (se->ss && se->ss->useflags)
+ if (se->ss && se->ss->info->useflags)
/* Access the previously obtained result. */
gfc_conv_tmp_array_ref (se);
else
for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
{
- if (tmp_ss->type != GFC_SS_SCALAR
- && tmp_ss->type != GFC_SS_REFERENCE)
+ if (tmp_ss->info->type != GFC_SS_SCALAR
+ && tmp_ss->info->type != GFC_SS_REFERENCE)
{
int tmp_dim;
- gfc_ss_info *info;
- info = &tmp_ss->data.info;
- gcc_assert (info->dimen == 2);
+ gcc_assert (tmp_ss->dimen == 2);
/* We just invert dimensions. */
- tmp_dim = info->dim[0];
- info->dim[0] = info->dim[1];
- info->dim[1] = tmp_dim;
+ tmp_dim = tmp_ss->dim[0];
+ tmp_ss->dim[0] = tmp_ss->dim[1];
+ tmp_ss->dim[1] = tmp_dim;
}
/* Stop when tmp_ss points to the last valid element of the chain... */
}
+/* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
+ This has the side effect of reversing the nested list, so there is no
+ need to call gfc_reverse_ss on it (the given list is assumed not to be
+ reversed yet). */
+
+static gfc_ss *
+nest_loop_dimension (gfc_ss *ss, int dim)
+{
+ int ss_dim, i;
+ gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
+ gfc_loopinfo *new_loop;
+
+ gcc_assert (ss != gfc_ss_terminator);
+
+ for (; ss != gfc_ss_terminator; ss = ss->next)
+ {
+ new_ss = gfc_get_ss ();
+ new_ss->next = prev_ss;
+ new_ss->parent = ss;
+ new_ss->info = ss->info;
+ new_ss->info->refcount++;
+ if (ss->dimen != 0)
+ {
+ gcc_assert (ss->info->type != GFC_SS_SCALAR
+ && ss->info->type != GFC_SS_REFERENCE);
+
+ new_ss->dimen = 1;
+ new_ss->dim[0] = ss->dim[dim];
+
+ gcc_assert (dim < ss->dimen);
+
+ ss_dim = --ss->dimen;
+ for (i = dim; i < ss_dim; i++)
+ ss->dim[i] = ss->dim[i + 1];
+
+ ss->dim[ss_dim] = 0;
+ }
+ prev_ss = new_ss;
+
+ if (ss->nested_ss)
+ {
+ ss->nested_ss->parent = new_ss;
+ new_ss->nested_ss = ss->nested_ss;
+ }
+ ss->nested_ss = new_ss;
+ }
+
+ new_loop = gfc_get_loopinfo ();
+ gfc_init_loopinfo (new_loop);
+
+ gcc_assert (prev_ss != NULL);
+ gcc_assert (prev_ss != gfc_ss_terminator);
+ gfc_add_ss_to_loop (new_loop, prev_ss);
+ return new_ss->parent;
+}
+
+
+/* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
+ is to be inlined. */
+
+static gfc_ss *
+walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
+{
+ gfc_ss *tmp_ss, *tail, *array_ss;
+ gfc_actual_arglist *arg1, *arg2, *arg3;
+ int sum_dim;
+ bool scalar_mask = false;
+
+ /* The rank of the result will be determined later. */
+ arg1 = expr->value.function.actual;
+ arg2 = arg1->next;
+ arg3 = arg2->next;
+ gcc_assert (arg3 != NULL);
+
+ if (expr->rank == 0)
+ return ss;
+
+ tmp_ss = gfc_ss_terminator;
+
+ if (arg3->expr)
+ {
+ gfc_ss *mask_ss;
+
+ mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
+ if (mask_ss == tmp_ss)
+ scalar_mask = 1;
+
+ tmp_ss = mask_ss;
+ }
+
+ array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
+ gcc_assert (array_ss != tmp_ss);
+
+ /* Odd thing: If the mask is scalar, it is used by the frontend after
+ the array (to make an if around the nested loop). Thus it shall
+ be after array_ss once the gfc_ss list is reversed. */
+ if (scalar_mask)
+ tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
+ else
+ tmp_ss = array_ss;
+
+ /* "Hide" the dimension on which we will sum in the first arg's scalarization
+ chain. */
+ sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
+ tail = nest_loop_dimension (tmp_ss, sum_dim);
+ tail->next = ss;
+
+ return tmp_ss;
+}
+
+
static gfc_ss *
walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
{
switch (expr->value.function.isym->id)
{
+ case GFC_ISYM_PRODUCT:
+ case GFC_ISYM_SUM:
+ return walk_inline_intrinsic_arith (ss, expr);
+
case GFC_ISYM_TRANSPOSE:
return walk_inline_intrinsic_transpose (ss, expr);
void
gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
{
- switch (ss->expr->value.function.isym->id)
+ switch (ss->info->expr->value.function.isym->id)
{
case GFC_ISYM_UBOUND:
case GFC_ISYM_LBOUND:
static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
{
+ if (expr->value.function.actual->expr->ts.type == BT_CLASS)
+ gfc_add_class_array_ref (expr->value.function.actual->expr);
+
/* The two argument version returns a scalar. */
if (expr->value.function.actual->next->expr)
return ss;
bool
gfc_inline_intrinsic_function_p (gfc_expr *expr)
{
+ gfc_actual_arglist *args;
+
if (!expr->value.function.isym)
return false;
switch (expr->value.function.isym->id)
{
+ case GFC_ISYM_PRODUCT:
+ case GFC_ISYM_SUM:
+ /* Disable inline expansion if code size matters. */
+ if (optimize_size)
+ return false;
+
+ args = expr->value.function.actual;
+ /* We need to be able to subset the SUM argument at compile-time. */
+ if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ return true;
+
case GFC_ISYM_TRANSPOSE:
return true;
if (isym->elemental)
return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
- GFC_SS_SCALAR);
+ NULL, GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
static tree
conv_intrinsic_move_alloc (gfc_code *code)
{
- if (code->ext.actual->expr->rank == 0)
- {
- /* Scalar arguments: Generate pointer assignments. */
- gfc_expr *from, *to, *deal;
- stmtblock_t block;
- tree tmp;
- gfc_se se;
+ stmtblock_t block;
+ gfc_expr *from_expr, *to_expr;
+ gfc_expr *to_expr2, *from_expr2 = NULL;
+ gfc_se from_se, to_se;
+ gfc_ss *from_ss, *to_ss;
+ tree tmp;
- from = code->ext.actual->expr;
- to = code->ext.actual->next->expr;
+ gfc_start_block (&block);
- gfc_start_block (&block);
+ from_expr = code->ext.actual->expr;
+ to_expr = code->ext.actual->next->expr;
- /* Deallocate 'TO' argument. */
- gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- deal = gfc_copy_expr (to);
- if (deal->ts.type == BT_CLASS)
- gfc_add_data_component (deal);
- gfc_conv_expr (&se, deal);
- tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
- deal, deal->ts);
- gfc_add_expr_to_block (&block, tmp);
- gfc_free_expr (deal);
+ gfc_init_se (&from_se, NULL);
+ gfc_init_se (&to_se, NULL);
+
+ gcc_assert (from_expr->ts.type != BT_CLASS
+ || to_expr->ts.type == BT_CLASS);
- if (to->ts.type == BT_CLASS)
- tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
+ if (from_expr->rank == 0)
+ {
+ if (from_expr->ts.type != BT_CLASS)
+ from_expr2 = from_expr;
else
- tmp = gfc_trans_pointer_assignment (to, from);
- gfc_add_expr_to_block (&block, tmp);
+ {
+ from_expr2 = gfc_copy_expr (from_expr);
+ gfc_add_data_component (from_expr2);
+ }
- if (from->ts.type == BT_CLASS)
- tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
- EXEC_POINTER_ASSIGN);
+ if (to_expr->ts.type != BT_CLASS)
+ to_expr2 = to_expr;
else
- tmp = gfc_trans_pointer_assignment (from,
- gfc_get_null_expr (NULL));
+ {
+ to_expr2 = gfc_copy_expr (to_expr);
+ gfc_add_data_component (to_expr2);
+ }
+
+ from_se.want_pointer = 1;
+ to_se.want_pointer = 1;
+ gfc_conv_expr (&from_se, from_expr2);
+ gfc_conv_expr (&to_se, to_expr2);
+ gfc_add_block_to_block (&block, &from_se.pre);
+ gfc_add_block_to_block (&block, &to_se.pre);
+
+ /* Deallocate "to". */
+ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
+ to_expr2, to_expr->ts);
gfc_add_expr_to_block (&block, tmp);
+ /* Assign (_data) pointers. */
+ gfc_add_modify_loc (input_location, &block, to_se.expr,
+ fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+
+ /* Set "from" to NULL. */
+ gfc_add_modify_loc (input_location, &block, from_se.expr,
+ fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
+
+ gfc_add_block_to_block (&block, &from_se.post);
+ gfc_add_block_to_block (&block, &to_se.post);
+
+ /* Set _vptr. */
+ if (to_expr->ts.type == BT_CLASS)
+ {
+ gfc_free_expr (to_expr2);
+ gfc_init_se (&to_se, NULL);
+ to_se.want_pointer = 1;
+ gfc_add_vptr_component (to_expr);
+ gfc_conv_expr (&to_se, to_expr);
+
+ if (from_expr->ts.type == BT_CLASS)
+ {
+ gfc_free_expr (from_expr2);
+ gfc_init_se (&from_se, NULL);
+ from_se.want_pointer = 1;
+ gfc_add_vptr_component (from_expr);
+ gfc_conv_expr (&from_se, from_expr);
+ tmp = from_se.expr;
+ }
+ else
+ {
+ gfc_symbol *vtab;
+ vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ }
+
+ gfc_add_modify_loc (input_location, &block, to_se.expr,
+ fold_convert (TREE_TYPE (to_se.expr), tmp));
+ }
+
return gfc_finish_block (&block);
}
- else
- /* Array arguments: Generate library code. */
- return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+
+ /* Update _vptr component. */
+ if (to_expr->ts.type == BT_CLASS)
+ {
+ to_se.want_pointer = 1;
+ to_expr2 = gfc_copy_expr (to_expr);
+ gfc_add_vptr_component (to_expr2);
+ gfc_conv_expr (&to_se, to_expr2);
+
+ if (from_expr->ts.type == BT_CLASS)
+ {
+ from_se.want_pointer = 1;
+ from_expr2 = gfc_copy_expr (from_expr);
+ gfc_add_vptr_component (from_expr2);
+ gfc_conv_expr (&from_se, from_expr2);
+ tmp = from_se.expr;
+ }
+ else
+ {
+ gfc_symbol *vtab;
+ vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+ gcc_assert (vtab);
+ tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+ }
+
+ gfc_add_modify_loc (input_location, &block, to_se.expr,
+ fold_convert (TREE_TYPE (to_se.expr), tmp));
+ gfc_free_expr (to_expr2);
+ gfc_init_se (&to_se, NULL);
+
+ if (from_expr->ts.type == BT_CLASS)
+ {
+ gfc_free_expr (from_expr2);
+ gfc_init_se (&from_se, NULL);
+ }
+ }
+
+ /* Deallocate "to". */
+ to_ss = gfc_walk_expr (to_expr);
+ from_ss = gfc_walk_expr (from_expr);
+ gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
+ gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
+
+ tmp = gfc_conv_descriptor_data_get (to_se.expr);
+ tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
+ NULL_TREE, true, to_expr, false);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Move the pointer and update the array descriptor data. */
+ gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
+
+ /* Set "to" to NULL. */
+ tmp = gfc_conv_descriptor_data_get (from_se.expr);
+ gfc_add_modify_loc (input_location, &block, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+
+ return gfc_finish_block (&block);
}
OSDN Git Service
