mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-15 07:40:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/12840 ([4.0 only] Unable to find scalarization loop specifier)

Browse Source 
PR fortran/12840
	* trans.h (gfor_fndecl_internal_realloc): Declare.
	(gfor_fndecl_internal_realloc64): Declare.
	* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
	(gfor_fndecl_internal_realloc64): New variable.
	(gfc_build_builtin_function_decls): Initialize them.
	* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
	* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
	to say whether the array can grow later.  Don't allocate the array
	on the stack if so.  Don't call malloc for zero-sized arrays.
	(gfc_trans_allocate_temp_array): Add a similar argument here.
	Pass it along to gfc_trans_allocate_array_storage.
	(gfc_get_iteration_count, gfc_grow_array): New functions.
	(gfc_iterator_has_dynamic_bounds): New function.
	(gfc_get_array_constructor_element_size): New function.
	(gfc_get_array_constructor_size): New function.
	(gfc_trans_array_ctor_element): Replace pointer argument with
	a descriptor tree.
	(gfc_trans_array_constructor_subarray): Likewise.  Take an extra
	argument to say whether the variable-sized part of the constructor
	must be allocated using realloc.  Grow the array when this
	argument is true.
	(gfc_trans_array_constructor_value): Likewise.
	(gfc_get_array_cons_size): Delete.
	(gfc_trans_array_constructor): If the loop bound has not been set,
	split the allocation into a static part and a dynamic part.  Set
	loop->to to the bounds for static part before allocating the
	temporary.  Adjust call to gfc_trans_array_constructor_value.
	(gfc_conv_loop_setup): Allow any constructor to determine the
	loop bounds.  Check whether the constructor has a dynamic size
	and prefer to use something else if so.  Expect the loop bound
	to be set later.  Adjust call to gfc_trans_allocate_temp_array.
	* trans-expr.c (gfc_conv_function_call): Adjust another call here.

From-SVN: r104073
This commit is contained in:
Richard Sandiford 2005-09-09 06:00:40 +00:00 committed by Richard Sandiford
parent 84bb243df1
commit ec25720ba3
16 changed files with 689 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gcc/fortran/ChangeLog
View File

@ -1,3 +1,39 @@
2005-09-09 Richard Sandiford <richard@codesourcery.com>
PR fortran/12840
* trans.h (gfor_fndecl_internal_realloc): Declare.
(gfor_fndecl_internal_realloc64): Declare.
* trans-decl.c (gfor_fndecl_internal_realloc): New variable.
(gfor_fndecl_internal_realloc64): New variable.
(gfc_build_builtin_function_decls): Initialize them.
* trans-array.h (gfc_trans_allocate_temp_array): Add a fourth argument.
* trans-array.c (gfc_trans_allocate_array_storage): Add an argument
to say whether the array can grow later. Don't allocate the array
on the stack if so. Don't call malloc for zero-sized arrays.
(gfc_trans_allocate_temp_array): Add a similar argument here.
Pass it along to gfc_trans_allocate_array_storage.
(gfc_get_iteration_count, gfc_grow_array): New functions.
(gfc_iterator_has_dynamic_bounds): New function.
(gfc_get_array_constructor_element_size): New function.
(gfc_get_array_constructor_size): New function.
(gfc_trans_array_ctor_element): Replace pointer argument with
a descriptor tree.
(gfc_trans_array_constructor_subarray): Likewise. Take an extra
argument to say whether the variable-sized part of the constructor
must be allocated using realloc. Grow the array when this
argument is true.
(gfc_trans_array_constructor_value): Likewise.
(gfc_get_array_cons_size): Delete.
(gfc_trans_array_constructor): If the loop bound has not been set,
split the allocation into a static part and a dynamic part. Set
loop->to to the bounds for static part before allocating the
temporary. Adjust call to gfc_trans_array_constructor_value.
(gfc_conv_loop_setup): Allow any constructor to determine the
loop bounds. Check whether the constructor has a dynamic size
and prefer to use something else if so. Expect the loop bound
to be set later. Adjust call to gfc_trans_allocate_temp_array.
* trans-expr.c (gfc_conv_function_call): Adjust another call here.
2005-09-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/18878

419
gcc/fortran/trans-array.c
View File

@ -94,6 +94,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
@ -435,11 +436,14 @@ gfc_trans_static_array_pointer (gfc_symbol * sym)
/* Generate code to allocate an array temporary, or create a variable to
hold the data. If size is NULL zero the descriptor so that so that the
callee will allocate the array. Also generates code to free the array
afterwards. */
afterwards.
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
static void
gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
tree size, tree nelem)
tree size, tree nelem, bool dynamic)
{
tree tmp;
tree args;
@ -448,7 +452,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
desc = info->descriptor;
info->offset = gfc_index_zero_node;
if (size == NULL_TREE)
if (size == NULL_TREE || integer_zerop (size))
{
/* A callee allocated array. */
gfc_conv_descriptor_data_set (&loop->pre, desc, null_pointer_node);
@ -457,7 +461,7 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
else
{
/* Allocate the temporary. */
onstack = gfc_can_put_var_on_stack (size);
onstack = !dynamic && gfc_can_put_var_on_stack (size);
if (onstack)
{
@ -512,11 +516,13 @@ gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info,
functions returning arrays. Adjusts the loop variables to be zero-based,
and calculates the loop bounds for callee allocated arrays.
Also fills in the descriptor, data and offset fields of info if known.
Returns the size of the array, or NULL for a callee allocated array. */
Returns the size of the array, or NULL for a callee allocated array.
DYNAMIC is as for gfc_trans_allocate_array_storage. */
tree
gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
tree eltype)
tree eltype, bool dynamic)
{
tree type;
tree desc;
@ -611,7 +617,7 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
TYPE_SIZE_UNIT (gfc_get_element_type (type)));
gfc_trans_allocate_array_storage (loop, info, size, nelem);
gfc_trans_allocate_array_storage (loop, info, size, nelem, dynamic);
if (info->dimen > loop->temp_dim)
loop->temp_dim = info->dimen;
@ -620,6 +626,149 @@ gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info,
}
/* Return the number of iterations in a loop that starts at START,
ends at END, and has step STEP. */
static tree
gfc_get_iteration_count (tree start, tree end, tree step)
{
tree tmp;
tree type;
type = TREE_TYPE (step);
tmp = fold_build2 (MINUS_EXPR, type, end, start);
tmp = fold_build2 (FLOOR_DIV_EXPR, type, tmp, step);
tmp = fold_build2 (PLUS_EXPR, type, tmp, build_int_cst (type, 1));
tmp = fold_build2 (MAX_EXPR, type, tmp, build_int_cst (type, 0));
return fold_convert (gfc_array_index_type, tmp);
}
/* Extend the data in array DESC by EXTRA elements. */
static void
gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
{
tree args;
tree tmp;
tree size;
tree ubound;
if (integer_zerop (extra))
return;
ubound = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
/* Add EXTRA to the upper bound. */
tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, extra);
gfc_add_modify_expr (pblock, ubound, tmp);
/* Get the value of the current data pointer. */
tmp = gfc_conv_descriptor_data_get (desc);
args = gfc_chainon_list (NULL_TREE, tmp);
/* Calculate the new array size. */
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node);
tmp = build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
args = gfc_chainon_list (args, tmp);
/* Pick the appropriate realloc function. */
if (gfc_index_integer_kind == 4)
tmp = gfor_fndecl_internal_realloc;
else if (gfc_index_integer_kind == 8)
tmp = gfor_fndecl_internal_realloc64;
else
gcc_unreachable ();
/* Set the new data pointer. */
tmp = gfc_build_function_call (tmp, args);
gfc_conv_descriptor_data_set (pblock, desc, tmp);
}
/* Return true if the bounds of iterator I can only be determined
at run time. */
static inline bool
gfc_iterator_has_dynamic_bounds (gfc_iterator * i)
{
return (i->start->expr_type != EXPR_CONSTANT
|| i->end->expr_type != EXPR_CONSTANT
|| i->step->expr_type != EXPR_CONSTANT);
}
/* Split the size of constructor element EXPR into the sum of two terms,
one of which can be determined at compile time and one of which must
be calculated at run time. Set *SIZE to the former and return true
if the latter might be nonzero. */
static bool
gfc_get_array_constructor_element_size (mpz_t * size, gfc_expr * expr)
{
if (expr->expr_type == EXPR_ARRAY)
return gfc_get_array_constructor_size (size, expr->value.constructor);
else if (expr->rank > 0)
{
/* Calculate everything at run time. */
mpz_set_ui (*size, 0);
return true;
}
else
{
/* A single element. */
mpz_set_ui (*size, 1);
return false;
}
}
/* Like gfc_get_array_constructor_element_size, but applied to the whole
of array constructor C. */
static bool
gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
{
gfc_iterator *i;
mpz_t val;
mpz_t len;
bool dynamic;
mpz_set_ui (*size, 0);
mpz_init (len);
mpz_init (val);
dynamic = false;
for (; c; c = c->next)
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
dynamic = true;
else
{
dynamic |= gfc_get_array_constructor_element_size (&len, c->expr);
if (i)
{
/* Multiply the static part of the element size by the
number of iterations. */
mpz_sub (val, i->end->value.integer, i->start->value.integer);
mpz_fdiv_q (val, val, i->step->value.integer);
mpz_add_ui (val, val, 1);
if (mpz_sgn (val) > 0)
mpz_mul (len, len, val);
else
mpz_set_ui (len, 0);
}
mpz_add (*size, *size, len);
}
}
mpz_clear (len);
mpz_clear (val);
return dynamic;
}
/* Make sure offset is a variable. */
static void
@ -638,7 +787,7 @@ gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
/* Assign an element of an array constructor. */
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree offset, gfc_se * se, gfc_expr * expr)
{
tree tmp;
@ -647,7 +796,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
gfc_conv_expr (se, expr);
/* Store the value. */
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_build_indirect_ref (gfc_conv_descriptor_data_get (desc));
tmp = gfc_build_array_ref (tmp, offset);
if (expr->ts.type == BT_CHARACTER)
{
@ -684,19 +833,23 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree pointer,
}
/* Add the contents of an array to the constructor. */
/* Add the contents of an array to the constructor. DYNAMIC is as for
gfc_trans_array_constructor_value. */
static void
gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
tree type ATTRIBUTE_UNUSED,
tree pointer, gfc_expr * expr,
tree * poffset, tree * offsetvar)
tree desc, gfc_expr * expr,
tree * poffset, tree * offsetvar,
bool dynamic)
{
gfc_se se;
gfc_ss *ss;
gfc_loopinfo loop;
stmtblock_t body;
tree tmp;
tree size;
int n;
/* We need this to be a variable so we can increment it. */
gfc_put_offset_into_var (pblock, poffset, offsetvar);
@ -715,6 +868,22 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
{
/* Set SIZE to the total number of elements in the subarray. */
size = gfc_index_one_node;
for (n = 0; n < loop.dimen; n++)
{
tmp = gfc_get_iteration_count (loop.from[n], loop.to[n],
gfc_index_one_node);
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
}
/* Grow the constructed array by SIZE elements. */
gfc_grow_array (&loop.pre, desc, size);
}
/* Make the loop body. */
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
@ -724,7 +893,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
if (expr->ts.type == BT_CHARACTER)
gfc_todo_error ("character arrays in constructors");
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se, expr);
gfc_trans_array_ctor_element (&body, desc, *poffset, &se, expr);
gcc_assert (se.ss == gfc_ss_terminator);
/* Increment the offset. */
@ -741,17 +910,23 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
}
/* Assign the values to the elements of an array constructor. */
/* Assign the values to the elements of an array constructor. DYNAMIC
is true if descriptor DESC only contains enough data for the static
size calculated by gfc_get_array_constructor_size. When true, memory
for the dynamic parts must be allocated using realloc. */
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
tree pointer, gfc_constructor * c,
tree * poffset, tree * offsetvar)
tree desc, gfc_constructor * c,
tree * poffset, tree * offsetvar,
bool dynamic)
{
tree tmp;
stmtblock_t body;
gfc_se se;
mpz_t size;
mpz_init (size);
for (; c; c = c->next)
{
/* If this is an iterator or an array, the offset must be a variable. */
@ -763,14 +938,14 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
if (c->expr->expr_type == EXPR_ARRAY)
{
/* Array constructors can be nested. */
gfc_trans_array_constructor_value (&body, type, pointer,
gfc_trans_array_constructor_value (&body, type, desc,
c->expr->value.constructor,
poffset, offsetvar);
poffset, offsetvar, dynamic);
}
else if (c->expr->rank > 0)
{
gfc_trans_array_constructor_subarray (&body, type, pointer,
c->expr, poffset, offsetvar);
gfc_trans_array_constructor_subarray (&body, type, desc, c->expr,
poffset, offsetvar, dynamic);
}
else
{
@ -790,8 +965,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
{
/* Scalar values. */
gfc_init_se (&se, NULL);
gfc_trans_array_ctor_element (&body, pointer, *poffset, &se,
c->expr);
gfc_trans_array_ctor_element (&body, desc, *poffset,
&se, c->expr);
*poffset = fold_build2 (PLUS_EXPR, gfc_array_index_type,
*poffset, gfc_index_one_node);
@ -813,13 +988,12 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, p->expr);
if (p->expr->ts.type == BT_CHARACTER
&& POINTER_TYPE_P (TREE_TYPE (TREE_TYPE
(TREE_TYPE (pointer)))))
&& POINTER_TYPE_P (type))
{
/* For constant character array constructors we build
an array of pointers. */
se.expr = gfc_build_addr_expr (pchar_type_node,
se.expr);
se.expr);
}
list = tree_cons (NULL_TREE, se.expr, list);
@ -846,7 +1020,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
init = tmp;
/* Use BUILTIN_MEMCPY to assign the values. */
tmp = gfc_build_indirect_ref (pointer);
tmp = gfc_conv_descriptor_data_get (desc);
tmp = gfc_build_indirect_ref (tmp);
tmp = gfc_build_array_ref (tmp, *poffset);
tmp = gfc_build_addr_expr (NULL, tmp);
init = gfc_build_addr_expr (NULL, init);
@ -887,6 +1062,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
tree loopvar;
tree exit_label;
tree loopbody;
tree tmp2;
loopbody = gfc_finish_block (&body);
@ -911,6 +1087,23 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_add_block_to_block (pblock, &se.pre);
step = gfc_evaluate_now (se.expr, pblock);
/* If this array expands dynamically, and the number of iterations
is not constant, we won't have allocated space for the static
part of C->EXPR's size. Do that now. */
if (dynamic && gfc_iterator_has_dynamic_bounds (c->iterator))
{
/* Get the number of iterations. */
tmp = gfc_get_iteration_count (loopvar, end, step);
/* Get the static part of C->EXPR's size. */
gfc_get_array_constructor_element_size (&size, c->expr);
tmp2 = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
/* Grow the array by TMP * TMP2 elements. */
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, tmp2);
gfc_grow_array (pblock, desc, tmp);
}
/* Generate the loop body. */
exit_label = gfc_build_label_decl (NULL_TREE);
gfc_start_block (&body);
@ -947,73 +1140,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
gfc_add_expr_to_block (pblock, tmp);
}
}
}
/* Get the size of an expression. Returns -1 if the size isn't constant.
Implied do loops with non-constant bounds are tricky because we must only
evaluate the bounds once. */
static void
gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c)
{
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_set_ui (*size, 0);
mpz_init (len);
mpz_init (val);
for (; c; c = c->next)
{
if (c->expr->expr_type == EXPR_ARRAY)
{
/* A nested array constructor. */
gfc_get_array_cons_size (&len, c->expr->value.constructor);
if (mpz_sgn (len) < 0)
{
mpz_set (*size, len);
mpz_clear (len);
mpz_clear (val);
return;
}
}
else
{
if (c->expr->rank > 0)
{
mpz_set_si (*size, -1);
mpz_clear (len);
mpz_clear (val);
return;
}
mpz_set_ui (len, 1);
}
if (c->iterator)
{
i = c->iterator;
if (i->start->expr_type != EXPR_CONSTANT
|| i->end->expr_type != EXPR_CONSTANT
|| i->step->expr_type != EXPR_CONSTANT)
{
mpz_set_si (*size, -1);
mpz_clear (len);
mpz_clear (val);
return;
}
mpz_add (val, i->end->value.integer, i->start->value.integer);
mpz_tdiv_q (val, val, i->step->value.integer);
mpz_add_ui (val, val, 1);
mpz_mul (len, len, val);
}
mpz_add (*size, *size, len);
}
mpz_clear (len);
mpz_clear (val);
mpz_clear (size);
}
@ -1104,19 +1231,20 @@ get_array_ctor_strlen (gfc_constructor * c, tree * len)
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
{
gfc_constructor *c;
tree offset;
tree offsetvar;
tree desc;
tree size;
tree type;
bool const_string;
bool dynamic;
ss->data.info.dimen = loop->dimen;
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
const_string = get_array_ctor_strlen (ss->expr->value.constructor,
&ss->string_length);
const_string = get_array_ctor_strlen (c, &ss->string_length);
if (!ss->string_length)
gfc_todo_error ("complex character array constructors");
@ -1130,16 +1258,39 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
type = gfc_typenode_for_spec (&ss->expr->ts);
}
size = gfc_trans_allocate_temp_array (loop, &ss->data.info, type);
/* See if the constructor determines the loop bounds. */
dynamic = false;
if (loop->to[0] == NULL_TREE)
{
mpz_t size;
/* We should have a 1-dimensional, zero-based loop. */
gcc_assert (loop->dimen == 1);
gcc_assert (integer_zerop (loop->from[0]));
/* Split the constructor size into a static part and a dynamic part.
Allocate the static size up-front and record whether the dynamic
size might be nonzero. */
mpz_init (size);
dynamic = gfc_get_array_constructor_size (&size, c);
mpz_sub_ui (size, size, 1);
loop->to[0] = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
mpz_clear (size);
}
gfc_trans_allocate_temp_array (loop, &ss->data.info, type, dynamic);
desc = ss->data.info.descriptor;
offset = gfc_index_zero_node;
offsetvar = gfc_create_var_np (gfc_array_index_type, "offset");
TREE_USED (offsetvar) = 0;
gfc_trans_array_constructor_value (&loop->pre, type,
ss->data.info.data,
ss->expr->value.constructor, &offset,
&offsetvar);
gfc_trans_array_constructor_value (&loop->pre, type, desc, c,
&offset, &offsetvar, dynamic);
/* If the array grows dynamically, the upper bound of the loop variable
is determined by the array's final upper bound. */
if (dynamic)
loop->to[0] = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[0]);
if (TREE_USED (offsetvar))
pushdecl (offsetvar);
@ -2411,6 +2562,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
tree tmp;
tree len;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
@ -2418,6 +2571,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
for (n = 0; n < loop->dimen; n++)
{
loopspec[n] = NULL;
dynamic[n] = false;
/* We use one SS term, and use that to determine the bounds of the
loop for this dimension. We try to pick the simplest term. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
@ -2435,17 +2589,15 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
gcc_assert (loop->dimen == 1);
/* Try to figure out the size of the constructor. */
/* TODO: avoid this by making the frontend set the shape. */
gfc_get_array_cons_size (&i, ss->expr->value.constructor);
/* A negative value means we failed. */
if (mpz_sgn (i) > 0)
{
mpz_sub_ui (i, i, 1);
loop->to[n] =
gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
loopspec[n] = ss;
}
/* Always prefer to use the constructor bounds if the size
can be determined at compile time. Prefer not to otherwise,
since the general case involves realloc, and it's better to
avoid that overhead if possible. */
c = ss->expr->value.constructor;
dynamic[n] = gfc_get_array_constructor_size (&i, c);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
}
@ -2466,31 +2618,30 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
specinfo = NULL;
info = &ss->data.info;
if (!specinfo)
loopspec[n] = ss;
/* Criteria for choosing a loop specifier (most important first):
doesn't need realloc
stride of one
known stride
known lower bound
known upper bound
*/
if (!specinfo)
else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n])
loopspec[n] = ss;
/* TODO: Is != constructor correct? */
else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR)
{
if (integer_onep (info->stride[n])
&& !integer_onep (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->stride[n])
&& !INTEGER_CST_P (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->start[n])
&& !INTEGER_CST_P (specinfo->start[n]))
loopspec[n] = ss;
/* We don't work out the upper bound.
else if (INTEGER_CST_P (info->finish[n])
&& ! INTEGER_CST_P (specinfo->finish[n]))
loopspec[n] = ss; */
}
else if (integer_onep (info->stride[n])
&& !integer_onep (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->stride[n])
&& !INTEGER_CST_P (specinfo->stride[n]))
loopspec[n] = ss;
else if (INTEGER_CST_P (info->start[n])
&& !INTEGER_CST_P (specinfo->start[n]))
loopspec[n] = ss;
/* We don't work out the upper bound.
else if (INTEGER_CST_P (info->finish[n])
&& ! INTEGER_CST_P (specinfo->finish[n]))
loopspec[n] = ss; */
}
if (!loopspec[n])
@ -2520,8 +2671,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
switch (loopspec[n]->type)
{
case GFC_SS_CONSTRUCTOR:
gcc_assert (info->dimen == 1);
gcc_assert (loop->to[n]);
/* The upper bound is calculated when we expand the
constructor. */
gcc_assert (loop->to[n] == NULL_TREE);
break;
case GFC_SS_SECTION:
@ -2575,7 +2727,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop)
memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info));
loop->temp_ss->type = GFC_SS_SECTION;
loop->temp_ss->data.info.dimen = n;
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, tmp);
gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info,
tmp, false);
}
for (n = 0; n < loop->temp_dim; n++)

2
gcc/fortran/trans-array.h
View File

@ -27,7 +27,7 @@ tree gfc_array_deallocate (tree, tree);
void gfc_array_allocate (gfc_se *, gfc_ref *, tree);
/* Generate code to allocate a temporary array. */
tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree);
tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, bool);
/* Generate function entry code for allocation of compiler allocated array
variables. */

14
gcc/fortran/trans-decl.c
View File

@ -73,6 +73,8 @@ tree gfc_static_ctors;
tree gfor_fndecl_internal_malloc;
tree gfor_fndecl_internal_malloc64;
tree gfor_fndecl_internal_realloc;
tree gfor_fndecl_internal_realloc64;
tree gfor_fndecl_internal_free;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate64;
@ -1891,6 +1893,18 @@ gfc_build_builtin_function_decls (void)
pvoid_type_node, 1, gfc_int8_type_node);
DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
gfor_fndecl_internal_realloc =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_realloc")),
pvoid_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
gfor_fndecl_internal_realloc64 =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_realloc64")),
pvoid_type_node, 2, pvoid_type_node,
gfc_int8_type_node);
gfor_fndecl_internal_free =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
void_type_node, 1, pvoid_type_node);

2
gcc/fortran/trans-expr.c
View File

@ -1694,7 +1694,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
info->dimen = se->loop->dimen;
/* Allocate a temporary to store the result. */
gfc_trans_allocate_temp_array (se->loop, info, tmp);
gfc_trans_allocate_temp_array (se->loop, info, tmp, false);
/* Zero the first stride to indicate a temporary. */
tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);

2
gcc/fortran/trans.h
View File

@ -443,6 +443,8 @@ tree builtin_function (const char *, tree, int, enum built_in_class,
/* Runtime library function decls. */
extern GTY(()) tree gfor_fndecl_internal_malloc;
extern GTY(()) tree gfor_fndecl_internal_malloc64;
extern GTY(()) tree gfor_fndecl_internal_realloc;
extern GTY(()) tree gfor_fndecl_internal_realloc64;
extern GTY(()) tree gfor_fndecl_internal_free;
extern GTY(()) tree gfor_fndecl_allocate;
extern GTY(()) tree gfor_fndecl_allocate64;

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2005-09-09 Richard Sandiford <richard@codesourcery.com>
PR fortran/12840
* gfortran.dg/array_constructor_6.f90
* gfortran.dg/array_constructor_7.f90
* gfortran.dg/array_constructor_8.f90
* gfortran.dg/array_constructor_9.f90
* gfortran.dg/array_constructor_10.f90
* gfortran.dg/array_constructor_11.f90
* gfortran.dg/array_constructor_12.f90: New tests.
2005-09-08 Josh Conner <jconner@apple.com>
PR c++/23180

27
gcc/testsuite/gfortran.dg/array_constructor_10.f90 Normal file
View File

@ -0,0 +1,27 @@
! Like array_constructor_6.f90, but check constructors that apply
! an elemental function to an array.
! { dg-do run }
program main
implicit none
call build (200)
contains
subroutine build (order)
integer :: order, i
call test (order, (/ (abs ((/ i, -i, -i * 2 /)), i = 1, order) /))
call test (order, abs ((/ ((/ -i, -i, i * 2 /), i = 1, order) /)))
call test (order, (/ abs ((/ ((/ i, i, -i * 2 /), i = 1, order) /)) /))
end subroutine build
subroutine test (order, values)
integer, dimension (3:) :: values
integer :: order, i
if (size (values, dim = 1) .ne. order * 3) call abort
do i = 1, order
if (values (i * 3) .ne. i) call abort
if (values (i * 3 + 1) .ne. i) call abort
if (values (i * 3 + 2) .ne. i * 2) call abort
end do
end subroutine test
end program main

47
gcc/testsuite/gfortran.dg/array_constructor_11.f90 Normal file
View File

@ -0,0 +1,47 @@
! Like array_constructor_6.f90, but check iterators with non-default stride,
! including combinations which lead to zero-length vectors.
! { dg-do run }
program main
implicit none
call build (77)
contains
subroutine build (order)
integer :: order, i, j
call test (1, 11, 3, (/ (i, i = 1, 11, 3) /))
call test (3, 20, 2, (/ (i, i = 3, 20, 2) /))
call test (4, 0, 11, (/ (i, i = 4, 0, 11) /))
call test (110, 10, -3, (/ (i, i = 110, 10, -3) /))
call test (200, 20, -12, (/ (i, i = 200, 20, -12) /))
call test (29, 30, -6, (/ (i, i = 29, 30, -6) /))
call test (1, order, 3, (/ (i, i = 1, order, 3) /))
call test (order, 1, -3, (/ (i, i = order, 1, -3) /))
! Triggers compile-time iterator calculations in trans-array.c
call test (1, 1000, 2, (/ (i, i = 1, 1000, 2), (i, i = order, 0, 1) /))
call test (1, 0, 3, (/ (i, i = 1, 0, 3), (i, i = order, 0, 1) /))
call test (1, 2000, -5, (/ (i, i = 1, 2000, -5), (i, i = order, 0, 1) /))
call test (3000, 99, 4, (/ (i, i = 3000, 99, 4), (i, i = order, 0, 1) /))
call test (400, 77, -39, (/ (i, i = 400, 77, -39), (i, i = order, 0, 1) /))
do j = -10, 10
call test (order + j, order, 5, (/ (i, i = order + j, order, 5) /))
call test (order + j, order, -5, (/ (i, i = order + j, order, -5) /))
end do
end subroutine build
subroutine test (from, to, step, values)
integer, dimension (:) :: values
integer :: from, to, step, last, i
last = 0
do i = from, to, step
last = last + 1
if (values (last) .ne. i) call abort
end do
if (size (values, dim = 1) .ne. last) call abort
end subroutine test
end program main

51
gcc/testsuite/gfortran.dg/array_constructor_12.f90 Normal file
View File

@ -0,0 +1,51 @@
! Like array_constructor_6.f90, but check integer(8) iterators.
! { dg-do run }
program main
integer (kind = 8) :: i, l8, u8, step8
integer (kind = 4) :: l4, step4
integer (kind = 8), parameter :: big = 10000000000_8
l4 = huge (1)
u8 = l4 + 10_8
step4 = 2
call test ((/ (i, i = l4, u8, step4) /), l4 + 0_8, u8, step4 + 0_8)
l8 = big
u8 = big * 20
step8 = big
call test ((/ (i, i = l8, u8, step8) /), l8, u8, step8)
u8 = big + 100
l8 = big
step4 = -20
call test ((/ (i, i = u8, l8, step4) /), u8, l8, step4 + 0_8)
u8 = big * 40
l8 = big * 20
step8 = -big * 2
call test ((/ (i, i = u8, l8, step8) /), u8, l8, step8)
u8 = big
l4 = big / 100
step4 = -big / 500
call test ((/ (i, i = u8, l4, step4) /), u8, l4 + 0_8, step4 + 0_8)
u8 = big * 40 + 200
l4 = 200
step8 = -big
call test ((/ (i, i = u8, l4, step8) /), u8, l4 + 0_8, step8)
contains
subroutine test (a, l, u, step)
integer (kind = 8), dimension (:), intent (in) :: a
integer (kind = 8), intent (in) :: l, u, step
integer (kind = 8) :: i
integer :: j
j = 1
do i = l, u, step
if (a (j) .ne. i) call abort
j = j + 1
end do
if (size (a, 1) .ne. j - 1) call abort
end subroutine test
end program main

25
gcc/testsuite/gfortran.dg/array_constructor_6.f90 Normal file
View File

@ -0,0 +1,25 @@
! PR 12840. Make sure that array constructors can be used to determine
! the bounds of a scalarization loop.
! { dg-do run }
program main
implicit none
call build (11)
contains
subroutine build (order)
integer :: order, i
call test (order, (/ (i * 2, i = 1, order) /))
call test (17, (/ (i * 2, i = 1, 17) /))
call test (5, (/ 2, 4, 6, 8, 10 /))
end subroutine build
subroutine test (order, values)
integer, dimension (:) :: values
integer :: order, i
if (size (values, dim = 1) .ne. order) call abort
do i = 1, order
if (values (i) .ne. i * 2) call abort
end do
end subroutine test
end program main

26
gcc/testsuite/gfortran.dg/array_constructor_7.f90 Normal file
View File

@ -0,0 +1,26 @@
! Like array_constructor_6.f90, but test for nested iterators.
! { dg-do run }
program main
implicit none
call build (17)
contains
subroutine build (order)
integer :: order, i, j
call test (order, (/ (((j + 100) * i, j = 1, i), i = 1, order) /))
call test (9, (/ (((j + 100) * i, j = 1, i), i = 1, 9) /))
call test (3, (/ 101, 202, 204, 303, 306, 309 /))
end subroutine build
subroutine test (order, values)
integer, dimension (:) :: values
integer :: order, i, j
if (size (values, dim = 1) .ne. order * (order + 1) / 2) call abort
do i = 1, order
do j = 1, i
if (values (i * (i - 1) / 2 + j) .ne. (j + 100) * i) call abort
end do
end do
end subroutine test
end program main

46
gcc/testsuite/gfortran.dg/array_constructor_8.f90 Normal file
View File

@ -0,0 +1,46 @@
! Like array_constructor_6.f90, but check constructors that mix iterators
! and individual scalar elements.
! { dg-do run }
program main
implicit none
call build (42)
contains
subroutine build (order)
integer :: order, i
call test (order, 8, 5, (/ ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), i = 1, order), &
100, 200, 300, 400, 500 /))
call test (order, 2, 3, (/ ((/ 1, 2 /), i = 1, order), &
100, 200, 300 /))
call test (order, 3, 5, (/ ((/ 1, 2, 3 /), i = 1, order), &
100, 200, 300, 400, 500 /))
call test (order, 6, 1, (/ ((/ 1, 2, 3, 4, 5, 6 /), i = 1, order), &
100 /))
call test (order, 5, 0, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, order) /))
call test (order, 0, 4, (/ 100, 200, 300, 400 /))
call test (11, 5, 2, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, 11), &
100, 200 /))
call test (6, 2, order, (/ ((/ 1, 2 /), i = 1, 6), &
(i * 100, i = 1, order) /))
end subroutine build
subroutine test (order, repeat, trail, values)
integer, dimension (:) :: values
integer :: order, repeat, trail, i
if (size (values, dim = 1) .ne. order * repeat + trail) call abort
do i = 1, order * repeat
if (values (i) .ne. mod (i - 1, repeat) + 1) call abort
end do
do i = 1, trail
if (values (i + order * repeat) .ne. i * 100) call abort
end do
end subroutine test
end program main

43
gcc/testsuite/gfortran.dg/array_constructor_9.f90 Normal file
View File

@ -0,0 +1,43 @@
! Like array_constructor_6.f90, but check constructors in which the length
! of each subarray can only be determined at run time.
! { dg-do run }
program main
implicit none
call build (9)
contains
function gen (order)
real, dimension (:, :), pointer :: gen
integer :: order, i, j
allocate (gen (order, order + 1))
forall (i = 1 : order, j = 1 : order + 1) gen (i, j) = i * i + j
end function gen
! Deliberately leaky!
subroutine build (order)
integer :: order, i
call test (order, 0, (/ (gen (i), i = 1, order) /))
call test (3, 2, (/ ((/ 1.5, 1.5, gen (i) /), i = 1, 3) /))
end subroutine build
subroutine test (order, prefix, values)
real, dimension (:) :: values
integer :: order, prefix, last, i, j, k
last = 0
do i = 1, order
do j = 1, prefix
last = last + 1
if (values (last) .ne. 1.5) call abort
end do
do j = 1, i + 1
do k = 1, i
last = last + 1
if (values (last) .ne. j + k * k) call abort
end do
end do
end do
if (size (values, dim = 1) .ne. last) call abort
end subroutine test
end program main

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2005-09-09 Richard Sandiford <richard@codesourcery.com>
PR fortran/12840
* runtime/memory.c (internal_malloc_size): Return a null pointer
if the size is zero.
(internal_free): Do nothing if the pointer is null.
(internal_realloc_size, internal_realloc, internal_realloc64): New.
2005-09-07 Francois-Xavier Coudert <coudert@clipper.ens.fr>
PR libfortran/23262

66
libgfortran/runtime/memory.c
View File

@ -141,6 +141,9 @@ internal_malloc_size (size_t size)
{
malloc_t *newmem;
if (size == 0)
return 0;
newmem = malloc_with_header (size);
if (!newmem)
@ -195,7 +198,7 @@ internal_free (void *mem)
malloc_t *m;
if (!mem)
runtime_error ("Internal: Possible double free of temporary.");
return;
m = DATA_HEADER (mem);
@ -213,6 +216,67 @@ internal_free (void *mem)
}
iexport(internal_free);
/* Reallocate internal memory MEM so it has SIZE bytes of data.
Allocate a new block if MEM is zero, and free the block if
SIZE is 0. */
static void *
internal_realloc_size (void *mem, size_t size)
{
malloc_t *m;
if (size == 0)
{
if (mem)
internal_free (mem);
return 0;
}
if (mem == 0)
return internal_malloc (size);
m = DATA_HEADER (mem);
if (m->magic != GFC_MALLOC_MAGIC)
runtime_error ("Internal: No magic memblock marker. "
"Possible memory corruption");
m = realloc (m, size + HEADER_SIZE);
if (!m)
os_error ("Out of memory.");
m->prev->next = m;
m->next->prev = m;
return DATA_POINTER (m);
}
extern void *internal_realloc (void *, GFC_INTEGER_4);
export_proto(internal_realloc);
void *
internal_realloc (void *mem, GFC_INTEGER_4 size)
{
#ifdef GFC_CHECK_MEMORY
/* Under normal circumstances, this is _never_ going to happen! */
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_realloc_size (mem, (size_t) size);
}
extern void *internal_realloc64 (void *, GFC_INTEGER_8);
export_proto(internal_realloc64);
void *
internal_realloc64 (void *mem, GFC_INTEGER_8 size)
{
#ifdef GFC_CHECK_MEMORY
/* Under normal circumstances, this is _never_ going to happen! */
if (size < 0)
runtime_error ("Attempt to allocate a negative amount of memory.");
#endif
return internal_realloc_size (mem, (size_t) size);
}
/* User-allocate, one call for each member of the alloc-list of an
ALLOCATE statement. */