https://gcc.gnu.org/g:1bc10b59c053a883d84ebe318b090eb258ae91b1
commit 1bc10b59c053a883d84ebe318b090eb258ae91b1
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Feb 17 22:59:01 2025 +0100
Correction régression pr108889.f90 realloc_on_assign*
Diff:
---
gcc/fortran/trans-array.cc | 75 +++++++++++++++++++++++++++++++++++-----------
gcc/fortran/trans-expr.cc | 23 --------------
2 files changed, 58 insertions(+), 40 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index fd83c6ae66a7..b4fd623f5cf7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -5742,12 +5742,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss *
ss, int base)
&& 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))))))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))
+ && !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
@@ -8314,7 +8317,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);
}
}
}
@@ -13598,6 +13604,52 @@ concat_str_length (gfc_expr* expr)
}
+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;
+ tree desc = info->descriptor;
+
+#define UPDATE_VALUE(field, value) \
+ do \
+ { \
+ if ((field) && VAR_P ((field))) \
+ { \
+ tree val = (value); \
+ gfc_add_modify (block, (field), val); \
+ } \
+ else \
+ (field) = gfc_evaluate_now ((field), block); \
+ } \
+ while (0)
+
+ UPDATE_VALUE (info->data, gfc_conv_descriptor_data_get (desc));
+ UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc));
+ info->saved_offset = info->offset;
+ for (int i = 0; i < s->dimen; i++)
+ {
+ int dim = s->dim[i];
+ tree tree_dim = gfc_rank_cst[dim];
+ UPDATE_VALUE (info->start[dim],
+ gfc_conv_descriptor_lbound_get (desc, tree_dim));
+ UPDATE_VALUE (info->end[dim],
+ gfc_conv_descriptor_ubound_get (desc, tree_dim));
+ UPDATE_VALUE (info->stride[dim],
+ gfc_conv_descriptor_stride_get (desc, tree_dim));
+ info->delta[dim] = gfc_evaluate_now (info->delta[dim], block);
+ }
+
+#undef UPDATE_VALUE
+ }
+}
+
+
/* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it. */
@@ -13690,7 +13742,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
&& !expr2->value.function.isym)
expr2->ts.u.cl->backend_decl = rss->info->string_length;
- gfc_start_block (&fblock);
+ gfc_init_block (&fblock);
/* Since the lhs is allocatable, this must be a descriptor type.
Get the data and array size. */
@@ -13962,10 +14014,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
the array offset is saved and the info.offset is used for a
running offset. Use the saved_offset instead. */
gfc_conv_descriptor_offset_set (&fblock, desc, offset);
- if (linfo->saved_offset
- && VAR_P (linfo->saved_offset))
- gfc_add_modify (&fblock, linfo->saved_offset,
- gfc_conv_descriptor_offset_get (desc));
/* Now set the deltas for the lhs. */
for (n = 0; n < expr1->rank; n++)
@@ -13975,8 +14023,6 @@ 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 (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
@@ -14197,17 +14243,12 @@ 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);
+ update_reallocated_descriptor (&fblock, loop);
+
return gfc_finish_block (&fblock);
}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8e7034f59420..ccb63e120715 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -12648,30 +12648,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr *
expr2, bool init_flag,
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
- stmtblock_t reallocation_block;
- gfc_init_block (&reallocation_block);
reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1,
expr2);
- gfc_add_expr_to_block (&reallocation_block, reallocation);
-
- 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;
- info->offset = gfc_evaluate_now (info->offset,
&reallocation_block);
- info->saved_offset = info->offset;
- for (int i = 0; i < s->dimen; i++)
- {
- int dim = s->dim[i];
- info->start[dim] = gfc_evaluate_now (info->start[dim],
&reallocation_block);
- info->end[dim] = gfc_evaluate_now (info->end[dim],
&reallocation_block);
- info->stride[dim] = gfc_evaluate_now (info->stride[dim],
&reallocation_block);
- info->delta[dim] = gfc_evaluate_now (info->delta[dim],
&reallocation_block);
- }
- }
- reallocation = gfc_finish_block (&reallocation_block);
}
/* Start the scalarized loop body. */
