OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/13465 (Data statement for large arrays compiles verrrry slllowwwly and shows quadratic behaviour.) 

PR 13465
        * data.c (find_con_by_offset): Search ordered list; handle
        elements with repeat counts.
        (gfc_assign_data_value_range): New.
        * gfortran.h (struct gfc_data_value): Make repeat unsigned.
        (gfc_assign_data_value_range): Declare.
        * match.c (top_val_list): Extract repeat count into a temporary.
        * resolve.c (values): Make left unsigned.
        (next_data_value): Don't decrement left.
        (check_data_variable): Use gfc_assign_data_value_range.

From-SVN: r86443
This commit is contained in:
Richard Henderson 2004-08-23 14:53:14 -07:00 committed by Richard Henderson
parent 9a870e6c4c
commit b85024359a
5 changed files with 240 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -1,3 +1,16 @@
2004-08-22 Richard Henderson <rth@redhat.com>
PR 13465
* data.c (find_con_by_offset): Search ordered list; handle
elements with repeat counts.
(gfc_assign_data_value_range): New.
* gfortran.h (struct gfc_data_value): Make repeat unsigned.
(gfc_assign_data_value_range): Declare.
* match.c (top_val_list): Extract repeat count into a temporary.
* resolve.c (values): Make left unsigned.
(next_data_value): Don't decrement left.
(check_data_variable): Use gfc_assign_data_value_range.
2004-08-22 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
* trans-const.c, trans-decl.c, trans-expr.c: Spelling fixes.

180
gcc/fortran/data.c
View File

@ -82,12 +82,40 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset)
static gfc_constructor *
find_con_by_offset (mpz_t offset, gfc_constructor *con)
{
mpz_t tmp;
gfc_constructor *ret = NULL;
mpz_init (tmp);
for (; con; con = con->next)
{
if (mpz_cmp (offset, con->n.offset) == 0)
return con;
int cmp = mpz_cmp (offset, con->n.offset);
/* We retain a sorted list, so if we're too large, we're done. */
if (cmp < 0)
break;
/* Yaye for exact matches. */
if (cmp == 0)
{
ret = con;
break;
}
/* If the constructor element is a range, match any element. */
if (mpz_cmp_ui (con->repeat, 1) > 0)
{
mpz_add (tmp, con->n.offset, con->repeat);
if (mpz_cmp (offset, tmp) < 0)
{
ret = con;
break;
}
}
}
return NULL;
mpz_clear (tmp);
return ret;
}
@ -236,7 +264,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor();
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
gfc_insert_constructor (expr, con);
}
@ -272,7 +300,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
abort ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
@ -295,7 +322,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
}
if (last_con == NULL)
@ -304,6 +330,148 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
last_con->expr = expr;
}
/* Similarly, but initialize REPEAT consectutive values in LVALUE the same
value in RVALUE. For the nonce, LVALUE must refer to a full array, not
an array section. */
void
gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
mpz_t index, mpz_t repeat)
{
gfc_ref *ref;
gfc_expr *init, *expr;
gfc_constructor *con, *last_con;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
last_ts = &symbol->ts;
last_con = NULL;
mpz_init_set_si (offset, 0);
/* Find/create the parent expressions for subobject references. */
for (ref = lvalue->ref; ref; ref = ref->next)
{
/* Use the existing initializer expression if it exists.
Otherwise create a new one. */
if (init == NULL)
expr = gfc_get_expr ();
else
expr = init;
/* Find or create this element. */
switch (ref->type)
{
case REF_ARRAY:
if (init == NULL)
{
/* The element typespec will be the same as the array
typespec. */
expr->ts = *last_ts;
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_ARRAY;
expr->rank = ref->u.ar.as->rank;
}
else
assert (expr->expr_type == EXPR_ARRAY);
if (ref->u.ar.type == AR_ELEMENT)
{
get_array_index (&ref->u.ar, &offset);
/* This had better not be the bottom of the reference.
We can still get to a full array via a component. */
assert (ref->next != NULL);
}
else
{
mpz_set (offset, index);
/* We're at a full array or an array section. This means
that we've better have found a full array, and that we're
at the bottom of the reference. */
assert (ref->u.ar.type == AR_FULL);
assert (ref->next == NULL);
}
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_offset (offset, con);
/* Create a new constructor. */
if (con == NULL)
{
con = gfc_get_constructor ();
mpz_set (con->n.offset, offset);
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
gfc_insert_constructor (expr, con);
}
else
assert (ref->next != NULL);
break;
case REF_COMPONENT:
if (init == NULL)
{
/* Setup the expression to hold the constructor. */
expr->expr_type = EXPR_STRUCTURE;
expr->ts.type = BT_DERIVED;
expr->ts.derived = ref->u.c.sym;
}
else
assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
con = expr->value.constructor;
con = find_con_by_component (ref->u.c.component, con);
if (con == NULL)
{
/* Create a new constructor. */
con = gfc_get_constructor ();
con->n.component = ref->u.c.component;
con->next = expr->value.constructor;
expr->value.constructor = con;
}
/* Since we're only intending to initialize arrays here,
there better be an inner reference. */
assert (ref->next != NULL);
break;
case REF_SUBSTRING:
default:
abort ();
}
if (init == NULL)
{
/* Point the container at the new expression. */
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
init = con->expr;
last_con = con;
}
/* We should never be overwriting an existing initializer. */
assert (!init);
expr = gfc_copy_expr (rvalue);
if (!gfc_compare_types (&lvalue->ts, &expr->ts))
gfc_convert_type (expr, &lvalue->ts, 0);
if (last_con == NULL)
symbol->value = expr;
else
last_con->expr = expr;
}
/* Modify the index of array section and re-calculate the array offset. */

4
gcc/fortran/gfortran.h
View File

@ -1304,9 +1304,8 @@ gfc_data_variable;
typedef struct gfc_data_value
{
int repeat;
unsigned int repeat;
gfc_expr *expr;
struct gfc_data_value *next;
}
gfc_data_value;
@ -1402,6 +1401,7 @@ extern iterator_stack *iter_stack;
void gfc_formalize_init_value (gfc_symbol *);
void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
/* scanner.c */

4
gcc/fortran/match.c
View File

@ -2894,13 +2894,15 @@ top_val_list (gfc_data * data)
}
else
{
msg = gfc_extract_int (expr, &tail->repeat);
signed int tmp;
msg = gfc_extract_int (expr, &tmp);
gfc_free_expr (expr);
if (msg != NULL)
{
gfc_error (msg);
return MATCH_ERROR;
}
tail->repeat = tmp;
m = match_data_constant (&tail->expr);
if (m == MATCH_NO)

64
gcc/fortran/resolve.c
View File

@ -4037,7 +4037,7 @@ resolve_symbol (gfc_symbol * sym)
static struct
{
gfc_data_value *vnode;
int left;
unsigned int left;
}
values;
@ -4047,7 +4047,6 @@ values;
static try
next_data_value (void)
{
while (values.left == 0)
{
if (values.vnode->next == NULL)
@ -4057,7 +4056,6 @@ next_data_value (void)
values.left = values.vnode->repeat;
}
values.left--;
return SUCCESS;
}
@ -4086,7 +4084,10 @@ check_data_variable (gfc_data_variable * var, locus * where)
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->rank == 0)
mpz_init_set_ui (size, 1);
{
mpz_init_set_ui (size, 1);
ref = NULL;
}
else
{
ref = e->ref;
@ -4145,19 +4146,54 @@ check_data_variable (gfc_data_variable * var, locus * where)
if (t == FAILURE)
break;
/* If we have more than one element left in the repeat count,
and we have more than one element left in the target variable,
then create a range assignment. */
/* ??? Only done for full arrays for now, since array sections
seem tricky. */
if (mark == AR_FULL && ref && ref->next == NULL
&& values.left > 1 && mpz_cmp_ui (size, 1) > 0)
{
mpz_t range;
if (mpz_cmp_ui (size, values.left) >= 0)
{
mpz_init_set_ui (range, values.left);
mpz_sub_ui (size, size, values.left);
values.left = 0;
}
else
{
mpz_init_set (range, size);
values.left -= mpz_get_ui (size);
mpz_set_ui (size, 0);
}
gfc_assign_data_value_range (var->expr, values.vnode->expr,
offset, range);
mpz_add (offset, offset, range);
mpz_clear (range);
}
/* Assign initial value to symbol. */
gfc_assign_data_value (var->expr, values.vnode->expr, offset);
else
{
values.left -= 1;
mpz_sub_ui (size, size, 1);
if (mark == AR_FULL)
mpz_add_ui (offset, offset, 1);
gfc_assign_data_value (var->expr, values.vnode->expr, offset);
/* Modify the array section indexes and recalculate the offset for
next element. */
else if (mark == AR_SECTION)
gfc_advance_section (section_index, ar, &offset);
if (mark == AR_FULL)
mpz_add_ui (offset, offset, 1);
mpz_sub_ui (size, size, 1);
/* Modify the array section indexes and recalculate the offset
for next element. */
else if (mark == AR_SECTION)
gfc_advance_section (section_index, ar, &offset);
}
}
if (mark == AR_SECTION)
{
for (i = 0; i < ar->dimen; i++)
@ -4253,7 +4289,6 @@ traverse_data_var (gfc_data_variable * var, locus * where)
static try
resolve_data_variables (gfc_data_variable * d)
{
for (; d; d = d->next)
{
if (d->list == NULL)
@ -4287,7 +4322,6 @@ resolve_data_variables (gfc_data_variable * d)
static void
resolve_data (gfc_data * d)
{
if (resolve_data_variables (d->var) == FAILURE)
return;
@ -4312,7 +4346,6 @@ resolve_data (gfc_data * d)
int
gfc_impure_variable (gfc_symbol * sym)
{
if (sym->attr.use_assoc || sym->attr.in_common)
return 1;
@ -4606,4 +4639,3 @@ gfc_resolve (gfc_namespace * ns)
gfc_current_ns = old_ns;
}