https://gcc.gnu.org/g:6b68aa726ed5a45e33bd2d87636e2daa5059fd65
commit 6b68aa726ed5a45e33bd2d87636e2daa5059fd65
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Jul 7 11:46:08 2025 +0200
fortran: Delay evaluation of array bounds after reallocation
Delay the evaluation of bounds, offset, etc after the reallocation,
for the scalarization of allocatable arrays on the left hand side of
assignments.
Before this change, the code preceding the scalarization loop is like:
D.4757 = ref2.offset;
D.4759 = ref2.dim[0].ubound;
D.4762 = ref2.dim[0].lbound;
{
if (ref2.data == 0B) goto realloc;
if (ref2.dim[0].lbound + 4 != ref2.dim[0].ubound) goto realloc;
goto L.10;
realloc:
... change offset and bounds ...
D.4757 = ref2.offset;
D.4762 = NON_LVALUE_EXPR <ref2.dim[0].lbound>;
... reallocation ...
L.10:;
}
while (1)
{
... scalarized code ...
so the bounds etc are evaluated first to variables, and the reallocation
code takes care to update the variables during the reallocation. This
is problematic because the variables' initialization references the
array bounds, which for unallocated arrays are uninitialized at the
evaluation point. This used to (correctly) cause uninitialized warnings
(see PR fortran/108889), and a workaround for variables was found, that
initializes the bounds of arrays variables to some value beforehand if
they are unallocated. For allocatable components, there is no warning
but the problem remains, some uninitialized values are used, even if
discarded later.
After this change the code becomes:
{
if (ref2.data == 0B) goto realloc;
if (ref2.dim[0].lbound + 4 != ref2.dim[0].ubound) goto realloc;
goto L.10;
realloc:;
... change offset and bounds ...
... reallocation ...
L.10:;
}
D.4762 = ref2.offset;
D.4763 = ref2.dim[0].lbound;
D.4764 = ref2.dim[0].ubound;
while (1)
{
... scalarized code
so the scalarizer avoids storing the values to variables at the time it
evaluates them, if the array is reallocatable on assignment. Instead,
it keeps expressions with references to the array descriptor fields,
expressions that remain valid through reallocation. After the
reallocation code has been generated, the expressions stored by the
scalarizer are evaluated in place to variables.
The decision to delay evaluation is based on the existing field
is_alloc_lhs, which requires a few tweaks to be alway correct wrt to
what its name suggests. Namely it should be set even if the assignment
right hand side is an intrinsic function, and it should not be set if
the right hand side is a scalar and neither if the -fno-realloc-lhs flag
is passed to the compiler.
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_conv_ss_descriptor): Don't evaluate
offset and data to a variable if is_alloc_lhs is set. Move the
existing evaluation decision condition for data...
(save_descriptor_data): ... here as a new predicate.
(evaluate_bound): Add argument save_value. Omit the evaluation
of the value to a variable if that argument isn't set.
(gfc_conv_expr_descriptor): Update caller.
(gfc_conv_section_startstride): Update caller. Set save_value
if is_alloc_lhs is not set. Omit the evaluation of stride to a
variable if save_value isn't set.
(gfc_set_delta): Omit the evaluation of delta to a variable
if is_alloc_lhs is set.
(gfc_is_reallocatable_lhs): Return false if flag_realloc_lhs
isn't set.
(gfc_alloc_allocatable_for_assignment): Don't update
the variables that may be stored in saved_offset, delta, and
data. Call instead...
(update_realloated_descriptor): ... this new procedure.
* trans-expr.cc (gfc_trans_assignment_1): Don't omit setting the
is_alloc_lhs flag if the right hand side is an intrinsic
function. Clear the flag if the right hand side is scalar.
Diff:
---
gcc/fortran/trans-array.cc | 137 ++++++++++++++++++++++++++++++++-------------
gcc/fortran/trans-expr.cc | 14 ++---
2 files changed, 104 insertions(+), 47 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7be2d7b11a62..7b83d3fab8d7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3420,6 +3420,23 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss,
bool subscript,
}
+/* Given an array descriptor expression DESCR and its data pointer DATA, decide
+ whether to either save the data pointer to a variable and use the variable
or
+ use the data pointer expression directly without any intermediary variable.
+ */
+
+static bool
+save_descriptor_data (tree descr, tree data)
+{
+ return !(DECL_P (data)
+ || (TREE_CODE (data) == ADDR_EXPR
+ && DECL_P (TREE_OPERAND (data, 0)))
+ || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr))
+ && TREE_CODE (descr) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0)))));
+}
+
+
/* Translate expressions for the descriptor and data pointer of a SS. */
/*GCC ARRAYS*/
@@ -3466,17 +3483,14 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss *
ss, int base)
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
- if (!(DECL_P (tmp)
- || (TREE_CODE (tmp) == ADDR_EXPR
- && DECL_P (TREE_OPERAND (tmp, 0)))
- || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
- && TREE_CODE (se.expr) == COMPONENT_REF
- && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
+ if (save_descriptor_data (se.expr, tmp) && !ss->is_alloc_lhs)
tmp = gfc_evaluate_now (tmp, block);
info->data = tmp;
tmp = gfc_conv_array_offset (se.expr);
- info->offset = gfc_evaluate_now (tmp, block);
+ if (!ss->is_alloc_lhs)
+ tmp = gfc_evaluate_now (tmp, block);
+ info->offset = tmp;
/* Make absolutely sure that the saved_offset is indeed saved
so that the variable is still accessible after the loops
@@ -4769,13 +4783,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo *
loop, stmtblock_t * body)
static void
evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
- tree desc, int dim, bool lbound, bool deferred)
+ tree desc, int dim, bool lbound, bool deferred, bool save_value)
{
gfc_se se;
gfc_expr * input_val = values[dim];
tree *output = &bounds[dim];
-
if (input_val)
{
/* Specified section bound. */
@@ -4801,7 +4814,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds,
gfc_expr ** values,
*output = lbound ? gfc_conv_array_lbound (desc, dim) :
gfc_conv_array_ubound (desc, dim);
}
- *output = gfc_evaluate_now (*output, block);
+ if (save_value)
+ *output = gfc_evaluate_now (*output, block);
}
@@ -4834,18 +4848,18 @@ gfc_conv_section_startstride (stmtblock_t * block,
gfc_ss * ss, int dim)
|| ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
desc = info->descriptor;
stride = ar->stride[dim];
-
+ bool save_value = !ss->is_alloc_lhs;
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
evaluate_bound (block, info->start, ar->start, desc, dim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, save_value);
/* Similarly calculate the end. Although this is not used in the
scalarizer, it is needed when checking bounds and where the end
is an expression with side-effects. */
evaluate_bound (block, info->end, ar->end, desc, dim, false,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, save_value);
/* Calculate the stride. */
@@ -4856,7 +4870,11 @@ gfc_conv_section_startstride (stmtblock_t * block,
gfc_ss * ss, int dim)
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
- info->stride[dim] = gfc_evaluate_now (se.expr, block);
+ tree value = se.expr;
+ if (save_value)
+ info->stride[dim] = gfc_evaluate_now (value, block);
+ else
+ info->stride[dim] = value;
}
}
@@ -5991,7 +6009,10 @@ gfc_set_delta (gfc_loopinfo *loop)
gfc_array_index_type,
info->start[dim], tmp);
- info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+ if (ss->is_alloc_lhs)
+ info->delta[dim] = tmp;
+ else
+ info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
}
}
}
@@ -8470,7 +8491,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gcc_assert (n == codim - 1);
evaluate_bound (&loop.pre, info->start, ar->start,
info->descriptor, n + ndim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, true);
loop.from[n + loop.dimen] = info->start[n + ndim];
}
else
@@ -11206,6 +11227,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
gfc_ref * ref;
gfc_symbol *sym;
+ if (!flag_realloc_lhs)
+ return false;
+
if (!expr->ref)
return false;
@@ -11330,6 +11354,55 @@ concat_str_length (gfc_expr* expr)
}
+/* Among the scalarization chain of LOOP, find the element associated with an
+ allocatable array on the lhs of an assignment and evaluate its fields
+ (bounds, offset, etc) to new variables, putting the new code in BLOCK. This
+ function is to be called after putting the reallocation code in BLOCK and
+ before the beginning of the scalarization loop body.
+
+ The fields to be saved are expected to hold on entry to the function
+ expressions referencing the array descriptor. Especially the expressions
+ shouldn't be already temporary variable references as the value saved before
+ reallocation would be incorrect after reallocation.
+ At the end of the function, the expressions have been replaced with variable
+ references. */
+
+static void
+update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
+{
+ for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
+ {
+ if (!s->is_alloc_lhs)
+ continue;
+
+ gcc_assert (s->info->type == GFC_SS_SECTION);
+ gfc_array_info *info = &s->info->data.array;
+
+#define SAVE_VALUE(value) \
+ do \
+ { \
+ value = gfc_evaluate_now (value, block); \
+ } \
+ while (0)
+
+ if (save_descriptor_data (info->descriptor, info->data))
+ SAVE_VALUE (info->data);
+ SAVE_VALUE (info->offset);
+ info->saved_offset = info->offset;
+ for (int i = 0; i < s->dimen; i++)
+ {
+ int dim = s->dim[i];
+ SAVE_VALUE (info->start[dim]);
+ SAVE_VALUE (info->end[dim]);
+ SAVE_VALUE (info->stride[dim]);
+ SAVE_VALUE (info->delta[dim]);
+ }
+
+#undef SAVE_VALUE
+ }
+}
+
+
/* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it. */
@@ -11368,7 +11441,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
tree lbd;
tree class_expr2 = NULL_TREE;
int n;
- int dim;
gfc_array_spec * as;
bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
&& gfc_caf_attr (expr1, true).codimension);
@@ -11736,21 +11808,6 @@ 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 (linfo->saved_offset
- && VAR_P (linfo->saved_offset))
- gfc_add_modify (&fblock, linfo->saved_offset, tmp);
-
- /* Now set the deltas for the lhs. */
- for (n = 0; n < expr1->rank; n++)
- {
- tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- dim = lss->dim[n];
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp,
- loop->from[dim]);
- if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
- gfc_add_modify (&fblock, linfo->delta[dim], tmp);
- }
/* Take into account _len of unlimited polymorphic entities, so that span
for array descriptors and allocation sizes are computed correctly. */
@@ -11972,18 +12029,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
- /* Make sure that the scalarizer data pointer is updated. */
- if (linfo->data && VAR_P (linfo->data))
- {
- tmp = gfc_conv_descriptor_data_get (desc);
- gfc_add_modify (&fblock, linfo->data, tmp);
- }
-
/* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
- return gfc_finish_block (&fblock);
+ tree realloc_code = gfc_finish_block (&fblock);
+
+ stmtblock_t result_block;
+ gfc_init_block (&result_block);
+ gfc_add_expr_to_block (&result_block, realloc_code);
+ update_reallocated_descriptor (&result_block, loop);
+
+ return gfc_finish_block (&result_block);
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 760c8c4e72bd..082987f9cb84 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12875,11 +12875,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
if (gfc_is_reallocatable_lhs (expr1))
{
lss->no_bounds_check = 1;
- if (!(expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL
- && !(expr2->value.function.isym->elemental
- || expr2->value.function.isym->conversion)))
- lss->is_alloc_lhs = 1;
+ lss->is_alloc_lhs = 1;
}
else
lss->no_bounds_check = expr1->no_bounds_check;
@@ -12962,8 +12958,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ {
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ lss->is_alloc_lhs = 0;
+ }
+
/* When doing a class assign, then the handle to the rhs needs to be a
pointer to allow for polymorphism. */
if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
