X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-array.c;h=3c0c11038079cfcce3b47ce68f223869b30d93e4;hb=5e8f57eb418d5e7f43d7dfc23a0edfeb461fdf93;hp=827d13d3946cead9fd8b678528350fffc3f300b6;hpb=3d653dea0f9e13fd2484d3ee3135800c2c93a0eb;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 827d13d3946..3c0c1103807 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -463,7 +463,7 @@ void gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) { for (; ss != gfc_ss_terminator; ss = ss->next) - ss->useflags = flags; + ss->info->useflags = flags; } static void gfc_free_ss (gfc_ss *); @@ -489,6 +489,11 @@ gfc_free_ss_chain (gfc_ss * ss) static void free_ss_info (gfc_ss_info *ss_info) { + ss_info->refcount--; + if (ss_info->refcount > 0) + return; + + gcc_assert (ss_info->refcount == 0); free (ss_info); } @@ -508,8 +513,8 @@ gfc_free_ss (gfc_ss * ss) case GFC_SS_SECTION: for (n = 0; n < ss->dimen; n++) { - if (ss->data.info.subscript[ss->dim[n]]) - gfc_free_ss_chain (ss->data.info.subscript[ss->dim[n]]); + if (ss_info->data.array.subscript[ss->dim[n]]) + gfc_free_ss_chain (ss_info->data.array.subscript[ss->dim[n]]); } break; @@ -532,6 +537,7 @@ gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) int i; ss_info = gfc_get_ss_info (); + ss_info->refcount++; ss_info->type = type; ss_info->expr = expr; @@ -556,13 +562,14 @@ gfc_get_temp_ss (tree type, tree string_length, int dimen) int i; ss_info = gfc_get_ss_info (); + ss_info->refcount++; ss_info->type = GFC_SS_TEMP; ss_info->string_length = string_length; + ss_info->data.temp.type = type; ss = gfc_get_ss (); ss->info = ss_info; ss->next = gfc_ss_terminator; - ss->data.temp.type = type; ss->dimen = dimen; for (i = 0; i < ss->dimen; i++) ss->dim[i] = i; @@ -580,6 +587,7 @@ gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) gfc_ss_info *ss_info; ss_info = gfc_get_ss_info (); + ss_info->refcount++; ss_info->type = GFC_SS_SCALAR; ss_info->expr = expr; @@ -596,6 +604,7 @@ gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) void gfc_cleanup_loop (gfc_loopinfo * loop) { + gfc_loopinfo *loop_next, **ploop; gfc_ss *ss; gfc_ss *next; @@ -607,6 +616,44 @@ gfc_cleanup_loop (gfc_loopinfo * loop) gfc_free_ss (ss); ss = next; } + + /* Remove reference to self in the parent loop. */ + if (loop->parent) + for (ploop = &loop->parent->nested; *ploop; ploop = &(*ploop)->next) + if (*ploop == loop) + { + *ploop = loop->next; + break; + } + + /* Free non-freed nested loops. */ + for (loop = loop->nested; loop; loop = loop_next) + { + loop_next = loop->next; + gfc_cleanup_loop (loop); + free (loop); + } +} + + +static void +set_ss_loop (gfc_ss *ss, gfc_loopinfo *loop) +{ + int n; + + for (; ss != gfc_ss_terminator; ss = ss->next) + { + ss->loop = loop; + + if (ss->info->type == GFC_SS_SCALAR + || ss->info->type == GFC_SS_REFERENCE + || ss->info->type == GFC_SS_TEMP) + continue; + + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + if (ss->info->data.array.subscript[n] != NULL) + set_ss_loop (ss->info->data.array.subscript[n], loop); + } } @@ -616,13 +663,36 @@ void gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) { gfc_ss *ss; + gfc_loopinfo *nested_loop; if (head == gfc_ss_terminator) return; + set_ss_loop (head, loop); + ss = head; for (; ss && ss != gfc_ss_terminator; ss = ss->next) { + if (ss->nested_ss) + { + nested_loop = ss->nested_ss->loop; + + /* More than one ss can belong to the same loop. Hence, we add the + loop to the chain only if it is different from the previously + added one, to avoid duplicate nested loops. */ + if (nested_loop != loop->nested) + { + gcc_assert (nested_loop->parent == NULL); + nested_loop->parent = loop; + + gcc_assert (nested_loop->next == NULL); + nested_loop->next = loop->nested; + loop->nested = nested_loop; + } + else + gcc_assert (nested_loop->parent == loop); + } + if (ss->next == gfc_ss_terminator) ss->loop_chain = loop->ss; else @@ -657,41 +727,54 @@ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, gfc_se * se, gfc_array_spec * as) { - int n, dim; + int n, dim, total_dim; gfc_se tmpse; + gfc_ss *ss; tree lower; tree upper; tree tmp; - if (as && as->type == AS_EXPLICIT) - for (n = 0; n < se->loop->dimen; n++) - { - dim = se->ss->dim[n]; - gcc_assert (dim < as->rank); - gcc_assert (se->loop->dimen == as->rank); - if (se->loop->to[n] == NULL_TREE) - { - /* Evaluate the lower bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - lower = fold_convert (gfc_array_index_type, tmpse.expr); - - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->loop->to[n] = tmp; - } - } + total_dim = 0; + + if (!as || as->type != AS_EXPLICIT) + return; + + for (ss = se->ss; ss; ss = ss->parent) + { + total_dim += ss->loop->dimen; + for (n = 0; n < ss->loop->dimen; n++) + { + /* The bound is known, nothing to do. */ + if (ss->loop->to[n] != NULL_TREE) + continue; + + dim = ss->dim[n]; + gcc_assert (dim < as->rank); + gcc_assert (ss->loop->dimen <= as->rank); + + /* Evaluate the lower bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->lower[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + lower = fold_convert (gfc_array_index_type, tmpse.expr); + + /* ...and the upper bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + upper = fold_convert (gfc_array_index_type, tmpse.expr); + + /* Set the upper bound of the loop to UPPER - LOWER. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = gfc_evaluate_now (tmp, &se->pre); + ss->loop->to[n] = tmp; + } + } + + gcc_assert (total_dim == as->rank); } @@ -824,28 +907,62 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, } -/* Get the array reference dimension corresponding to the given loop dimension. - It is different from the true array dimension given by the dim array in - the case of a partial array reference - It is different from the loop dimension in the case of a transposed array. - */ +/* Get the scalarizer array dimension corresponding to actual array dimension + given by ARRAY_DIM. + + For example, if SS represents the array ref a(1,:,:,1), it is a + bidimensional scalarizer array, and the result would be 0 for ARRAY_DIM=1, + and 1 for ARRAY_DIM=2. + If SS represents transpose(a(:,1,1,:)), it is again a bidimensional + scalarizer array, and the result would be 1 for ARRAY_DIM=0 and 0 for + ARRAY_DIM=3. + If SS represents sum(a(:,:,:,1), dim=1), it is a 2+1-dimensional scalarizer + array. If called on the inner ss, the result would be respectively 0,1,2 for + ARRAY_DIM=0,1,2. If called on the outer ss, the result would be 0,1 + for ARRAY_DIM=1,2. */ static int -get_array_ref_dim (gfc_ss *ss, int loop_dim) +get_scalarizer_dim_for_array_dim (gfc_ss *ss, int array_dim) { - int n, array_dim, array_ref_dim; + int array_ref_dim; + int n; array_ref_dim = 0; - array_dim = ss->dim[loop_dim]; - for (n = 0; n < ss->dimen; n++) - if (ss->dim[n] < array_dim) - array_ref_dim++; + for (; ss; ss = ss->parent) + for (n = 0; n < ss->dimen; n++) + if (ss->dim[n] < array_dim) + array_ref_dim++; return array_ref_dim; } +static gfc_ss * +innermost_ss (gfc_ss *ss) +{ + while (ss->nested_ss != NULL) + ss = ss->nested_ss; + + return ss; +} + + + +/* Get the array reference dimension corresponding to the given loop dimension. + It is different from the true array dimension given by the dim array in + the case of a partial array reference (i.e. a(:,:,1,:) for example) + It is different from the loop dimension in the case of a transposed array. + */ + +static int +get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim) +{ + return get_scalarizer_dim_for_array_dim (innermost_ss (ss), + ss->dim[loop_dim]); +} + + /* Generate code to create and initialize the descriptor for a temporary array. This is used for both temporaries needed by the scalarizer, and functions returning arrays. Adjusts the loop variables to be @@ -857,15 +974,15 @@ get_array_ref_dim (gfc_ss *ss, int loop_dim) callee allocated array. PRE, POST, INITIAL, DYNAMIC and DEALLOC are as for - gfc_trans_allocate_array_storage. - */ + gfc_trans_allocate_array_storage. */ tree -gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, - gfc_loopinfo * loop, gfc_ss * ss, +gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, tree eltype, tree initial, bool dynamic, bool dealloc, bool callee_alloc, locus * where) { + gfc_loopinfo *loop; + gfc_ss *s; gfc_array_info *info; tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS]; tree type; @@ -876,51 +993,63 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, tree cond; tree or_expr; int n, dim, tmp_dim; + int total_dim = 0; memset (from, 0, sizeof (from)); memset (to, 0, sizeof (to)); - info = &ss->data.info; + info = &ss->info->data.array; gcc_assert (ss->dimen > 0); - gcc_assert (loop->dimen == ss->dimen); + gcc_assert (ss->loop->dimen == ss->dimen); if (gfc_option.warn_array_temp && where) gfc_warning ("Creating array temporary at %L", where); /* Set the lower bound to zero. */ - for (n = 0; n < loop->dimen; n++) + for (s = ss; s; s = s->parent) { - dim = ss->dim[n]; + loop = s->loop; + + total_dim += loop->dimen; + for (n = 0; n < loop->dimen; n++) + { + dim = s->dim[n]; - /* Callee allocated arrays may not have a known bound yet. */ - if (loop->to[n]) - loop->to[n] = gfc_evaluate_now ( + /* Callee allocated arrays may not have a known bound yet. */ + if (loop->to[n]) + loop->to[n] = gfc_evaluate_now ( fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]), pre); - loop->from[n] = gfc_index_zero_node; - - /* We are constructing the temporary's descriptor based on the loop - dimensions. As the dimensions may be accessed in arbitrary order - (think of transpose) the size taken from the n'th loop may not map - to the n'th dimension of the array. We need to reconstruct loop infos - in the right order before using it to set the descriptor - bounds. */ - tmp_dim = get_array_ref_dim (ss, n); - from[tmp_dim] = loop->from[n]; - to[tmp_dim] = loop->to[n]; - - info->delta[dim] = gfc_index_zero_node; - info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; - info->stride[dim] = gfc_index_one_node; + loop->from[n] = gfc_index_zero_node; + + /* We have just changed the loop bounds, we must clear the + corresponding specloop, so that delta calculation is not skipped + later in set_delta. */ + loop->specloop[n] = NULL; + + /* We are constructing the temporary's descriptor based on the loop + dimensions. As the dimensions may be accessed in arbitrary order + (think of transpose) the size taken from the n'th loop may not map + to the n'th dimension of the array. We need to reconstruct loop + infos in the right order before using it to set the descriptor + bounds. */ + tmp_dim = get_scalarizer_dim_for_array_dim (ss, dim); + from[tmp_dim] = loop->from[n]; + to[tmp_dim] = loop->to[n]; + + info->delta[dim] = gfc_index_zero_node; + info->start[dim] = gfc_index_zero_node; + info->end[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + } } /* Initialize the descriptor. */ type = - gfc_get_array_type_bounds (eltype, ss->dimen, 0, from, to, 1, + gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1, GFC_ARRAY_UNKNOWN, true); desc = gfc_create_var (type, "atmp"); GFC_DECL_PACKED_ARRAY (desc) = 1; @@ -949,59 +1078,61 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, /* If there is at least one null loop->to[n], it is a callee allocated array. */ - for (n = 0; n < loop->dimen; n++) - if (loop->to[n] == NULL_TREE) + for (n = 0; n < total_dim; n++) + if (to[n] == NULL_TREE) { size = NULL_TREE; break; } - for (n = 0; n < loop->dimen; n++) - { - dim = ss->dim[n]; - - if (size == NULL_TREE) + if (size == NULL_TREE) + for (s = ss; s; s = s->parent) + for (n = 0; n < s->loop->dimen; n++) { + dim = get_scalarizer_dim_for_array_dim (ss, ss->dim[n]); + /* For a callee allocated array express the loop bounds in terms of the descriptor fields. */ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); - loop->to[n] = tmp; - continue; + s->loop->to[n] = tmp; } - - /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + else + { + for (n = 0; n < total_dim; n++) + { + /* Store the stride and bound components in the descriptor. */ + gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], - gfc_index_zero_node); + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_index_zero_node); - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], - to[n]); + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - to[n], gfc_index_one_node); + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + to[n], gfc_index_one_node); - /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, tmp, - gfc_index_zero_node); - cond = gfc_evaluate_now (cond, pre); + /* Check whether the size for this dimension is negative. */ + cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + tmp, gfc_index_zero_node); + cond = gfc_evaluate_now (cond, pre); - if (n == 0) - or_expr = cond; - else - or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, or_expr, cond); + if (n == 0) + or_expr = cond; + else + or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, or_expr, cond); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, tmp); - size = gfc_evaluate_now (size, pre); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); + size = gfc_evaluate_now (size, pre); + } } /* Get the size of the array. */ - if (size && !callee_alloc) { /* If or_expr is true, then the extent in at least one @@ -1024,8 +1155,11 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, dynamic, dealloc); - if (ss->dimen > loop->temp_dim) - loop->temp_dim = ss->dimen; + while (ss->parent) + ss = ss->parent; + + if (ss->dimen > ss->loop->temp_dim) + ss->loop->temp_dim = ss->dimen; return size; } @@ -1884,7 +2018,7 @@ trans_constant_array_constructor (gfc_ss * ss, tree type) tmp = gfc_build_constant_array_constructor (ss->info->expr, type); - info = &ss->data.info; + info = &ss->info->data.array; info->descriptor = tmp; info->data = gfc_build_addr_expr (NULL_TREE, tmp); @@ -1899,50 +2033,97 @@ trans_constant_array_constructor (gfc_ss * ss, tree type) } } + +static int +get_rank (gfc_loopinfo *loop) +{ + int rank; + + rank = 0; + for (; loop; loop = loop->parent) + rank += loop->dimen; + + return rank; +} + + /* Helper routine of gfc_trans_array_constructor to determine if the bounds of the loop specified by LOOP are constant and simple enough to use with trans_constant_array_constructor. Returns the iteration count of the loop if suitable, and NULL_TREE otherwise. */ static tree -constant_array_constructor_loop_size (gfc_loopinfo * loop) +constant_array_constructor_loop_size (gfc_loopinfo * l) { + gfc_loopinfo *loop; tree size = gfc_index_one_node; tree tmp; - int i; + int i, total_dim; - for (i = 0; i < loop->dimen; i++) + total_dim = get_rank (l); + + for (loop = l; loop; loop = loop->parent) { - /* If the bounds aren't constant, return NULL_TREE. */ - if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) - return NULL_TREE; - if (!integer_zerop (loop->from[i])) + for (i = 0; i < loop->dimen; i++) { - /* Only allow nonzero "from" in one-dimensional arrays. */ - if (loop->dimen != 1) + /* If the bounds aren't constant, return NULL_TREE. */ + if (!INTEGER_CST_P (loop->from[i]) || !INTEGER_CST_P (loop->to[i])) return NULL_TREE; - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[i], loop->from[i]); + if (!integer_zerop (loop->from[i])) + { + /* Only allow nonzero "from" in one-dimensional arrays. */ + if (total_dim != 1) + return NULL_TREE; + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + loop->to[i], loop->from[i]); + } + else + tmp = loop->to[i]; + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tmp, gfc_index_one_node); + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, tmp); } - else - tmp = loop->to[i]; - tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - tmp, gfc_index_one_node); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, tmp); } return size; } +static tree * +get_loop_upper_bound_for_array (gfc_ss *array, int array_dim) +{ + gfc_ss *ss; + int n; + + gcc_assert (array->nested_ss == NULL); + + for (ss = array; ss; ss = ss->parent) + for (n = 0; n < ss->loop->dimen; n++) + if (array_dim == get_array_ref_dim_for_loop_dim (ss, n)) + return &(ss->loop->to[n]); + + gcc_unreachable (); +} + + +static gfc_loopinfo * +outermost_loop (gfc_loopinfo * loop) +{ + while (loop->parent != NULL) + loop = loop->parent; + + return loop; +} + + /* Array constructors are handled by constructing a temporary, then using that within the scalarization loop. This is not optimal, but seems by far the simplest method. */ static void -gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) +trans_array_constructor (gfc_ss * ss, locus * where) { gfc_constructor_base c; tree offset; @@ -1950,17 +2131,22 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) tree desc; tree type; tree tmp; + tree *loop_ubound0; bool dynamic; bool old_first_len, old_typespec_chararray_ctor; tree old_first_len_val; + gfc_loopinfo *loop, *outer_loop; gfc_ss_info *ss_info; gfc_expr *expr; + gfc_ss *s; /* Save the old values for nested checking. */ old_first_len = first_len; old_first_len_val = first_len_val; old_typespec_chararray_ctor = typespec_chararray_ctor; + loop = ss->loop; + outer_loop = outermost_loop (loop); ss_info = ss->info; expr = ss_info->expr; @@ -1976,7 +2162,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) first_len = true; } - gcc_assert (ss->dimen == loop->dimen); + gcc_assert (ss->dimen == ss->loop->dimen); c = expr->value.constructor; if (expr->ts.type == BT_CHARACTER) @@ -1996,11 +2182,11 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) gfc_conv_expr_type (&length_se, expr->ts.u.cl->length, gfc_charlen_type_node); ss_info->string_length = length_se.expr; - gfc_add_block_to_block (&loop->pre, &length_se.pre); - gfc_add_block_to_block (&loop->post, &length_se.post); + gfc_add_block_to_block (&outer_loop->pre, &length_se.pre); + gfc_add_block_to_block (&outer_loop->post, &length_se.post); } else - const_string = get_array_ctor_strlen (&loop->pre, c, + const_string = get_array_ctor_strlen (&outer_loop->pre, c, &ss_info->string_length); /* Complex character array constructors should have been taken care of @@ -2019,26 +2205,33 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) /* See if the constructor determines the loop bounds. */ dynamic = false; - if (expr->shape && loop->dimen > 1 && loop->to[0] == NULL_TREE) + loop_ubound0 = get_loop_upper_bound_for_array (ss, 0); + + if (expr->shape && get_rank (loop) > 1 && *loop_ubound0 == NULL_TREE) { /* We have a multidimensional parameter. */ - int n; - for (n = 0; n < expr->rank; n++) - { - loop->from[n] = gfc_index_zero_node; - loop->to[n] = gfc_conv_mpz_to_tree (expr->shape [n], - gfc_index_integer_kind); - loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - loop->to[n], gfc_index_one_node); - } + for (s = ss; s; s = s->parent) + { + int n; + for (n = 0; n < s->loop->dimen; n++) + { + s->loop->from[n] = gfc_index_zero_node; + s->loop->to[n] = gfc_conv_mpz_to_tree (expr->shape[s->dim[n]], + gfc_index_integer_kind); + s->loop->to[n] = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + s->loop->to[n], + gfc_index_one_node); + } + } } - if (loop->to[0] == NULL_TREE) + if (*loop_ubound0 == NULL_TREE) { mpz_t size; /* We should have a 1-dimensional, zero-based loop. */ + gcc_assert (loop->parent == NULL && loop->nested == NULL); gcc_assert (loop->dimen == 1); gcc_assert (integer_zerop (loop->from[0])); @@ -2067,18 +2260,18 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) } } - if (TREE_CODE (loop->to[0]) == VAR_DECL) + if (TREE_CODE (*loop_ubound0) == VAR_DECL) dynamic = true; - gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, ss, - type, NULL_TREE, dynamic, true, false, where); + gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type, + NULL_TREE, dynamic, true, false, where); - desc = ss->data.info.descriptor; + desc = ss_info->data.array.descriptor; offset = gfc_index_zero_node; offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); TREE_NO_WARNING (offsetvar) = 1; TREE_USED (offsetvar) = 0; - gfc_trans_array_constructor_value (&loop->pre, type, desc, c, + gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, &offset, &offsetvar, dynamic); /* If the array grows dynamically, the upper bound of the loop variable @@ -2088,12 +2281,12 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, offsetvar, gfc_index_one_node); - tmp = gfc_evaluate_now (tmp, &loop->pre); + tmp = gfc_evaluate_now (tmp, &outer_loop->pre); gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); - if (loop->to[0] && TREE_CODE (loop->to[0]) == VAR_DECL) - gfc_add_modify (&loop->pre, loop->to[0], tmp); + if (*loop_ubound0 && TREE_CODE (*loop_ubound0) == VAR_DECL) + gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); else - loop->to[0] = tmp; + *loop_ubound0 = tmp; } if (TREE_USED (offsetvar)) @@ -2123,8 +2316,9 @@ finish: loop bounds. */ static void -set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss) +set_vector_loop_bounds (gfc_ss * ss) { + gfc_loopinfo *loop, *outer_loop; gfc_array_info *info; gfc_se se; tree tmp; @@ -2133,14 +2327,21 @@ set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss) int n; int dim; - info = &ss->data.info; + outer_loop = outermost_loop (ss->loop); - for (n = 0; n < loop->dimen; n++) + info = &ss->info->data.array; + + for (; ss; ss = ss->parent) { - dim = ss->dim[n]; - if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR - && loop->to[n] == NULL) + loop = ss->loop; + + for (n = 0; n < loop->dimen; n++) { + dim = ss->dim[n]; + if (info->ref->u.ar.dimen_type[dim] != DIMEN_VECTOR + || loop->to[n] != NULL) + continue; + /* Loop variable N indexes vector dimension DIM, and we don't yet know the upper bound of loop variable N. Set it to the difference between the vector's upper and lower bounds. */ @@ -2149,13 +2350,13 @@ set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss * ss) && info->subscript[dim]->info->type == GFC_SS_VECTOR); gfc_init_se (&se, NULL); - desc = info->subscript[dim]->data.info.descriptor; + desc = info->subscript[dim]->info->data.array.descriptor; zero = gfc_rank_cst[0]; tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, gfc_conv_descriptor_ubound_get (desc, zero), gfc_conv_descriptor_lbound_get (desc, zero)); - tmp = gfc_evaluate_now (tmp, &loop->pre); + tmp = gfc_evaluate_now (tmp, &outer_loop->pre); loop->to[n] = tmp; } } @@ -2170,11 +2371,16 @@ static void gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, locus * where) { + gfc_loopinfo *nested_loop, *outer_loop; gfc_se se; gfc_ss_info *ss_info; + gfc_array_info *info; gfc_expr *expr; + bool skip_nested = false; int n; + outer_loop = outermost_loop (loop); + /* TODO: This can generate bad code if there are ordering dependencies, e.g., a callee allocated function and an unknown size constructor. */ gcc_assert (ss != NULL); @@ -2183,8 +2389,13 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, { gcc_assert (ss); + /* Cross loop arrays are handled from within the most nested loop. */ + if (ss->nested_ss != NULL) + continue; + ss_info = ss->info; expr = ss_info->expr; + info = &ss_info->data.array; switch (ss_info->type) { @@ -2193,7 +2404,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, dimension indices, but not array section bounds. */ gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); if (expr->ts.type != BT_CHARACTER) { @@ -2201,14 +2412,14 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, scalarization loop, except for WHERE assignments. */ if (subscript) se.expr = convert(gfc_array_index_type, se.expr); - if (!ss->where) - se.expr = gfc_evaluate_now (se.expr, &loop->pre); - gfc_add_block_to_block (&loop->pre, &se.post); + if (!ss_info->where) + se.expr = gfc_evaluate_now (se.expr, &outer_loop->pre); + gfc_add_block_to_block (&outer_loop->pre, &se.post); } else - gfc_add_block_to_block (&loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->post, &se.post); - ss->data.scalar.expr = se.expr; + ss_info->data.scalar.value = se.expr; ss_info->string_length = se.string_length; break; @@ -2217,30 +2428,35 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, now. */ gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&loop->pre, &se.pre); - gfc_add_block_to_block (&loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); - ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre); + ss_info->data.scalar.value = gfc_evaluate_now (se.expr, + &outer_loop->pre); ss_info->string_length = se.string_length; break; case GFC_SS_SECTION: /* Add the expressions for scalar and vector subscripts. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - if (ss->data.info.subscript[n]) - gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true, - where); - - set_vector_loop_bounds (loop, ss); + if (info->subscript[n]) + { + gfc_add_loop_ss_code (loop, info->subscript[n], true, where); + /* The recursive call will have taken care of the nested loops. + No need to do it twice. */ + skip_nested = true; + } + + set_vector_loop_bounds (ss); break; case GFC_SS_VECTOR: /* Get the vector's descriptor and store it in SS. */ gfc_init_se (&se, NULL); gfc_conv_expr_descriptor (&se, expr, gfc_walk_expr (expr)); - gfc_add_block_to_block (&loop->pre, &se.pre); - gfc_add_block_to_block (&loop->post, &se.post); - ss->data.info.descriptor = se.expr; + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + info->descriptor = se.expr; break; case GFC_SS_INTRINSIC: @@ -2254,8 +2470,8 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, se.loop = loop; se.ss = ss; gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&loop->pre, &se.pre); - gfc_add_block_to_block (&loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); ss_info->string_length = se.string_length; break; @@ -2269,10 +2485,10 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gfc_conv_expr_type (&se, expr->ts.u.cl->length, gfc_charlen_type_node); ss_info->string_length = se.expr; - gfc_add_block_to_block (&loop->pre, &se.pre); - gfc_add_block_to_block (&loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); } - gfc_trans_array_constructor (loop, ss, where); + trans_array_constructor (ss, where); break; case GFC_SS_TEMP: @@ -2284,6 +2500,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gcc_unreachable (); } } + + if (!skip_nested) + for (nested_loop = loop->nested; nested_loop; + nested_loop = nested_loop->next) + gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where); } @@ -2295,9 +2516,11 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) { gfc_se se; gfc_ss_info *ss_info; + gfc_array_info *info; tree tmp; ss_info = ss->info; + info = &ss_info->data.array; /* Get the descriptor for the array to be scalarized. */ gcc_assert (ss_info->expr->expr_type == EXPR_VARIABLE); @@ -2305,7 +2528,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) se.descriptor_only = 1; gfc_conv_expr_lhs (&se, ss_info->expr); gfc_add_block_to_block (block, &se.pre); - ss->data.info.descriptor = se.expr; + info->descriptor = se.expr; ss_info->string_length = se.string_length; if (base) @@ -2320,15 +2543,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) || (TREE_CODE (tmp) == ADDR_EXPR && DECL_P (TREE_OPERAND (tmp, 0))))) tmp = gfc_evaluate_now (tmp, block); - ss->data.info.data = tmp; + info->data = tmp; tmp = gfc_conv_array_offset (se.expr); - ss->data.info.offset = gfc_evaluate_now (tmp, block); + info->offset = gfc_evaluate_now (tmp, block); /* Make absolutely sure that the saved_offset is indeed saved so that the variable is still accessible after the loops are translated. */ - ss->data.info.saved_offset = ss->data.info.offset; + info->saved_offset = info->offset; } } @@ -2481,7 +2704,7 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) return index; - descriptor = ss->data.info.descriptor; + descriptor = ss->info->data.array.descriptor; index = gfc_evaluate_now (index, &se->pre); @@ -2555,7 +2778,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, tree desc; tree data; - info = &ss->data.info; + info = &ss->info->data.array; /* Get the index into the array for this dimension. */ if (ar) @@ -2571,7 +2794,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, gcc_assert (info->subscript[dim] && info->subscript[dim]->info->type == GFC_SS_SCALAR); /* We've already translated this value outside the loop. */ - index = info->subscript[dim]->data.scalar.expr; + index = info->subscript[dim]->info->data.scalar.value; index = trans_array_bound_check (se, ss, index, dim, &ar->where, ar->as->type != AS_ASSUMED_SIZE @@ -2582,7 +2805,7 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, gcc_assert (info && se->loop); gcc_assert (info->subscript[dim] && info->subscript[dim]->info->type == GFC_SS_VECTOR); - desc = info->subscript[dim]->data.info.descriptor; + desc = info->subscript[dim]->info->data.array.descriptor; /* Get a zero-based index into the vector. */ index = fold_build2_loc (input_location, MINUS_EXPR, @@ -2673,7 +2896,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) ss = se->ss; expr = ss->info->expr; - info = &ss->data.info; + info = &ss->info->data.array; if (ar) n = se->loop->order[0]; else @@ -2866,7 +3089,7 @@ add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss, gfc_array_info *info; tree stride, index; - info = &ss->data.info; + info = &ss->info->data.array; gfc_init_se (&se, NULL); se.loop = loop; @@ -2890,9 +3113,11 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, stmtblock_t * pblock) { tree stride; + gfc_ss_info *ss_info; gfc_array_info *info; gfc_ss_type ss_type; - gfc_ss *ss; + gfc_ss *ss, *pss; + gfc_loopinfo *ploop; gfc_array_ref *ar; int i; @@ -2900,17 +3125,19 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, for this dimension. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { - if ((ss->useflags & flag) == 0) + ss_info = ss->info; + + if ((ss_info->useflags & flag) == 0) continue; - ss_type = ss->info->type; + ss_type = ss_info->type; if (ss_type != GFC_SS_SECTION && ss_type != GFC_SS_FUNCTION && ss_type != GFC_SS_CONSTRUCTOR && ss_type != GFC_SS_COMPONENT) continue; - info = &ss->data.info; + info = &ss_info->data.array; gcc_assert (dim < ss->dimen); gcc_assert (ss->dimen == loop->dimen); @@ -2920,18 +3147,37 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, else ar = NULL; + if (dim == loop->dimen - 1 && loop->parent != NULL) + { + /* If we are in the outermost dimension of this loop, the previous + dimension shall be in the parent loop. */ + gcc_assert (ss->parent != NULL); + + pss = ss->parent; + ploop = loop->parent; + + /* ss and ss->parent are about the same array. */ + gcc_assert (ss_info == pss->info); + } + else + { + ploop = loop; + pss = ss; + } + if (dim == loop->dimen - 1) i = 0; else i = dim + 1; /* For the time being, there is no loop reordering. */ - gcc_assert (i == loop->order[i]); - i = loop->order[i]; + gcc_assert (i == ploop->order[i]); + i = ploop->order[i]; - if (dim == loop->dimen - 1) + if (dim == loop->dimen - 1 && loop->parent == NULL) { - stride = gfc_conv_array_stride (info->descriptor, ss->dim[i]); + stride = gfc_conv_array_stride (info->descriptor, + innermost_ss (ss)->dim[i]); /* Calculate the stride of the innermost loop. Hopefully this will allow the backend optimizers to do their stuff more effectively. @@ -2954,10 +3200,10 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, } else /* Add the offset for the previous loop dimension. */ - add_array_offset (pblock, loop, ss, ar, ss->dim[i], i); + add_array_offset (pblock, ploop, ss, ar, pss->dim[i], i); /* Remember this offset for the second loop. */ - if (dim == loop->temp_dim - 1) + if (dim == loop->temp_dim - 1 && loop->parent == NULL) info->saved_offset = info->offset; } } @@ -3142,7 +3388,8 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) /* Clear all the used flags. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) - ss->useflags = 0; + if (ss->parent == NULL) + ss->info->useflags = 0; } @@ -3175,18 +3422,21 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { gfc_ss_type ss_type; + gfc_ss_info *ss_info; + + ss_info = ss->info; - if ((ss->useflags & 2) == 0) + if ((ss_info->useflags & 2) == 0) continue; - ss_type = ss->info->type; + ss_type = ss_info->type; if (ss_type != GFC_SS_SECTION && ss_type != GFC_SS_FUNCTION && ss_type != GFC_SS_CONSTRUCTOR && ss_type != GFC_SS_COMPONENT) continue; - ss->data.info.offset = ss->data.info.saved_offset; + ss_info->data.array.offset = ss_info->data.array.saved_offset; } /* Restart all the inner loops we just finished. */ @@ -3253,7 +3503,7 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) gcc_assert (ss->info->type == GFC_SS_SECTION); - info = &ss->data.info; + info = &ss->info->data.array; ar = &info->ref->u.ar; if (ar->dimen_type[dim] == DIMEN_VECTOR) @@ -3352,7 +3602,7 @@ done: ss_info = ss->info; expr = ss_info->expr; - info = &ss->data.info; + info = &ss_info->data.array; if (expr && expr->shape && !info->shape) info->shape = expr->shape; @@ -3360,8 +3610,10 @@ done: switch (ss_info->type) { case GFC_SS_SECTION: - /* Get the descriptor for the array. */ - gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); + /* Get the descriptor for the array. If it is a cross loops array, + we got the descriptor already in the outermost loop. */ + if (ss->parent == NULL) + gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); for (n = 0; n < ss->dimen; n++) gfc_conv_section_startstride (loop, ss, ss->dim[n]); @@ -3388,9 +3640,9 @@ done: { int dim = ss->dim[n]; - ss->data.info.start[dim] = gfc_index_zero_node; - ss->data.info.end[dim] = gfc_index_zero_node; - ss->data.info.stride[dim] = gfc_index_one_node; + info->start[dim] = gfc_index_zero_node; + info->end[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; } break; @@ -3439,7 +3691,7 @@ done: gfc_start_block (&inner); /* TODO: range checking for mapped dimensions. */ - info = &ss->data.info; + info = &ss_info->data.array; /* This code only checks ranges. Elemental and vector dimensions are checked later. */ @@ -3466,7 +3718,7 @@ done: expr_loc, msg); free (msg); - desc = ss->data.info.descriptor; + desc = info->descriptor; /* This is the run-time equivalent of resolve.c's check_dimension(). The logical is more readable there @@ -3650,6 +3902,9 @@ done: tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&loop->pre, tmp); } + + for (loop = loop->nested; loop; loop = loop->next) + gfc_conv_ss_startstride (loop); } /* Return true if both symbols could refer to the same data object. Does @@ -3720,7 +3975,7 @@ gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) /* For derived types we must check all the component types. We can ignore array references as these will have the same base type as the previous component ref. */ - for (lref = lexpr->ref; lref != lss->data.info.ref; lref = lref->next) + for (lref = lexpr->ref; lref != lss->info->data.array.ref; lref = lref->next) { if (lref->type != REF_COMPONENT) continue; @@ -3740,7 +3995,7 @@ gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) return 1; } - for (rref = rexpr->ref; rref != rss->data.info.ref; + for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) { if (rref->type != REF_COMPONENT) @@ -3775,7 +4030,7 @@ gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) lsym_pointer = lsym->attr.pointer; lsym_target = lsym->attr.target; - for (rref = rexpr->ref; rref != rss->data.info.ref; rref = rref->next) + for (rref = rexpr->ref; rref != rss->info->data.array.ref; rref = rref->next) { if (rref->type != REF_COMPONENT) break; @@ -3910,25 +4165,25 @@ temporary: } -/* Initialize the scalarization loop. Creates the loop variables. Determines - the range of the loop variables. Creates a temporary if required. - Calculates how to transform from loop variables to array indices for each - expression. Also generates code for scalar expressions which have been - moved outside the loop. */ +/* Browse through each array's information from the scalarizer and set the loop + bounds according to the "best" one (per dimension), i.e. the one which + provides the most information (constant bounds, shape, etc). */ -void -gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) +static void +set_loop_bounds (gfc_loopinfo *loop) { int n, dim, spec_dim; gfc_array_info *info; gfc_array_info *specinfo; - gfc_ss *ss, *tmp_ss; + gfc_ss *ss; tree tmp; - gfc_ss *loopspec[GFC_MAX_DIMENSIONS]; + gfc_ss **loopspec; bool dynamic[GFC_MAX_DIMENSIONS]; mpz_t *cshape; mpz_t i; + loopspec = loop->specloop; + mpz_init (i); for (n = 0; n < loop->dimen; n++) { @@ -3946,12 +4201,12 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) || ss_type == GFC_SS_REFERENCE) continue; - info = &ss->data.info; + info = &ss->info->data.array; dim = ss->dim[n]; if (loopspec[n] != NULL) { - specinfo = &loopspec[n]->data.info; + specinfo = &loopspec[n]->info->data.array; spec_dim = loopspec[n]->dim[n]; } else @@ -4039,7 +4294,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) that's bad news. */ gcc_assert (loopspec[n]); - info = &loopspec[n]->data.info; + info = &loopspec[n]->info->data.array; dim = loopspec[n]->dim[n]; /* Set the extents of this range. */ @@ -4048,7 +4303,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) && INTEGER_CST_P (info->stride[dim])) { loop->from[n] = info->start[dim]; - mpz_set (i, cshape[get_array_ref_dim (loopspec[n], n)]); + mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]); mpz_sub_ui (i, i, 1); /* To = from + (size - 1) * stride. */ tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); @@ -4110,6 +4365,28 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) loop->from[n] = gfc_index_zero_node; } } + mpz_clear (i); + + for (loop = loop->nested; loop; loop = loop->next) + set_loop_bounds (loop); +} + + +static void set_delta (gfc_loopinfo *loop); + + +/* Initialize the scalarization loop. Creates the loop variables. Determines + the range of the loop variables. Creates a temporary if required. + Also generates code for scalar expressions which have been + moved outside the loop. */ + +void +gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) +{ + gfc_ss *tmp_ss; + tree tmp; + + set_loop_bounds (loop); /* Add all the scalar code that can be taken out of the loops. This may include calculating the loop bounds, so do it before @@ -4124,35 +4401,48 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) tmp_ss_info = tmp_ss->info; gcc_assert (tmp_ss_info->type == GFC_SS_TEMP); + gcc_assert (loop->parent == NULL); /* Make absolutely sure that this is a complete type. */ if (tmp_ss_info->string_length) - loop->temp_ss->data.temp.type + tmp_ss_info->data.temp.type = gfc_get_character_type_len_for_eltype - (TREE_TYPE (loop->temp_ss->data.temp.type), + (TREE_TYPE (tmp_ss_info->data.temp.type), tmp_ss_info->string_length); - tmp = loop->temp_ss->data.temp.type; - memset (&loop->temp_ss->data.info, 0, sizeof (gfc_array_info)); + tmp = tmp_ss_info->data.temp.type; + memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info)); tmp_ss_info->type = GFC_SS_SECTION; gcc_assert (tmp_ss->dimen != 0); - gfc_trans_create_temp_array (&loop->pre, &loop->post, loop, - tmp_ss, tmp, NULL_TREE, - false, true, false, where); + gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp, + NULL_TREE, false, true, false, where); } - for (n = 0; n < loop->temp_dim; n++) - loopspec[loop->order[n]] = NULL; - - mpz_clear (i); - /* For array parameters we don't have loop variables, so don't calculate the translations. */ if (loop->array_parameter) return; + set_delta (loop); +} + + +/* Calculates how to transform from loop variables to array indices for each + array: once loop bounds are chosen, sets the difference (DELTA field) between + loop bounds and array reference bounds, for each array info. */ + +static void +set_delta (gfc_loopinfo *loop) +{ + gfc_ss *ss, **loopspec; + gfc_array_info *info; + tree tmp; + int n, dim; + + loopspec = loop->specloop; + /* Calculate the translation from loop variables to array indices. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { @@ -4164,7 +4454,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) && ss_type != GFC_SS_CONSTRUCTOR) continue; - info = &ss->data.info; + info = &ss->info->data.array; for (n = 0; n < ss->dimen; n++) { @@ -4190,6 +4480,9 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } } } + + for (loop = loop->nested; loop; loop = loop->next) + set_delta (loop); } @@ -5805,7 +6098,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gcc_assert (ss_type == GFC_SS_SECTION); gcc_assert (ss_expr == expr); - info = &ss->data.info; + info = &ss_info->data.array; /* Get the descriptor for the array. */ gfc_conv_ss_descriptor (&se->pre, ss, 0); @@ -5915,7 +6208,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) else { /* Transformational function. */ - info = &ss->data.info; + info = &ss_info->data.array; need_tmp = 0; } break; @@ -5927,7 +6220,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) && gfc_constant_array_constructor_p (expr->value.constructor)) { need_tmp = 0; - info = &ss->data.info; + info = &ss_info->data.array; } else { @@ -6027,7 +6320,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Finish the copying loops. */ gfc_trans_scalarizing_loops (&loop, &block); - desc = loop.temp_ss->data.info.descriptor; + desc = loop.temp_ss->info->data.array.descriptor; } else if (expr->expr_type == EXPR_FUNCTION && !transposed_dims (ss)) { @@ -6134,7 +6427,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { gcc_assert (info->subscript[n] && info->subscript[n]->info->type == GFC_SS_SCALAR); - start = info->subscript[n]->data.scalar.expr; + start = info->subscript[n]->info->data.scalar.value; } else { @@ -7220,6 +7513,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, stmtblock_t fblock; gfc_ss *rss; gfc_ss *lss; + gfc_array_info *linfo; tree realloc_expr; tree alloc_expr; tree size1; @@ -7271,6 +7565,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, if (lss == gfc_ss_terminator) return NULL_TREE; + linfo = &lss->info->data.array; + /* Find an ss for the rhs. For operator expressions, we see the ss's for the operands. Any one of these will do. */ rss = loop->ss; @@ -7285,7 +7581,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* Since the lhs is allocatable, this must be a descriptor type. Get the data and array size. */ - desc = lss->data.info.descriptor; + desc = linfo->descriptor; gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); array1 = gfc_conv_descriptor_data_get (desc); @@ -7355,7 +7651,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* Get the rhs size. Fix both sizes. */ if (expr2) - desc2 = rss->data.info.descriptor; + desc2 = rss->info->data.array.descriptor; else desc2 = NULL_TREE; size2 = gfc_index_one_node; @@ -7445,9 +7741,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, running offset. Use the saved_offset instead. */ tmp = gfc_conv_descriptor_offset (desc); gfc_add_modify (&fblock, tmp, offset); - if (lss->data.info.saved_offset - && TREE_CODE (lss->data.info.saved_offset) == VAR_DECL) - gfc_add_modify (&fblock, lss->data.info.saved_offset, tmp); + if (linfo->saved_offset + && TREE_CODE (linfo->saved_offset) == VAR_DECL) + gfc_add_modify (&fblock, linfo->saved_offset, tmp); /* Now set the deltas for the lhs. */ for (n = 0; n < expr1->rank; n++) @@ -7457,9 +7753,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, tmp, loop->from[dim]); - if (lss->data.info.delta[dim] - && TREE_CODE (lss->data.info.delta[dim]) == VAR_DECL) - gfc_add_modify (&fblock, lss->data.info.delta[dim], tmp); + if (linfo->delta[dim] + && TREE_CODE (linfo->delta[dim]) == VAR_DECL) + gfc_add_modify (&fblock, linfo->delta[dim], tmp); } /* Get the new lhs size in bytes. */ @@ -7523,11 +7819,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_add_expr_to_block (&fblock, tmp); /* Make sure that the scalarizer data pointer is updated. */ - if (lss->data.info.data - && TREE_CODE (lss->data.info.data) == VAR_DECL) + if (linfo->data + && TREE_CODE (linfo->data) == VAR_DECL) { tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, lss->data.info.data, tmp); + gfc_add_modify (&fblock, linfo->data, tmp); } /* Add the exit label. */ @@ -7717,7 +8013,7 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) case AR_FULL: newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); - newss->data.info.ref = ref; + newss->info->data.array.ref = ref; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ @@ -7735,7 +8031,7 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) case AR_SECTION: newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); - newss->data.info.ref = ref; + newss->info->data.array.ref = ref; /* We add SS chains for all the subscripts in the section. */ for (n = 0; n < ar->dimen; n++) @@ -7749,7 +8045,7 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) gcc_assert (ar->start[n]); indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); indexss->loop_chain = gfc_ss_terminator; - newss->data.info.subscript[n] = indexss; + newss->info->data.array.subscript[n] = indexss; break; case DIMEN_RANGE: @@ -7765,7 +8061,7 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], 1, GFC_SS_VECTOR); indexss->loop_chain = gfc_ss_terminator; - newss->data.info.subscript[n] = indexss; + newss->info->data.array.subscript[n] = indexss; newss->dim[newss->dimen] = n; newss->dimen++; break; @@ -7778,7 +8074,7 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) /* We should have at least one non-elemental dimension, unless we are creating a descriptor for a (scalar) coarray. */ gcc_assert (newss->dimen > 0 - || newss->data.info.ref->u.ar.as->corank > 0); + || newss->info->data.array.ref->u.ar.as->corank > 0); ss = newss; break;