https://gcc.gnu.org/g:7ed00263a569c00bf6bf52ea343e677b873e0e2f
commit 7ed00263a569c00bf6bf52ea343e677b873e0e2f
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Sat Jan 4 21:36:13 2025 +0100
Factorisation gfc_conv_remap_descriptor
Correction régression pointer_remapping_5
Diff:
---
gcc/fortran/trans-array.cc | 119 +++++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-expr.cc | 124 +++------------------------------------------
gcc/fortran/trans.h | 2 +
3 files changed, 129 insertions(+), 116 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5d56a12ebf71..898930634ad1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1332,6 +1332,125 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree
desc,
}
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_spec &as)
+{
+ int dest_rank = gfc_descriptor_rank (dest);
+
+ /* Set dtype. */
+ tree dtype = gfc_conv_descriptor_dtype (dest);
+ tree tmp = gfc_get_dtype (TREE_TYPE (src));
+ gfc_add_modify (block, dtype, tmp);
+
+ /* Copy data pointer. */
+ tree data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, data);
+
+ /* Copy the span. */
+ tree span;
+ if (VAR_P (src)
+ && GFC_DECL_PTR_ARRAY_P (src))
+ span = gfc_conv_descriptor_span_get (src);
+ else
+ {
+ tmp = TREE_TYPE (src);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+ }
+ gfc_conv_descriptor_span_set (block, dest, span);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ if (src_rank == -1)
+ gfc_conv_descriptor_offset_set (block, dest,
+ gfc_index_zero_node);
+ else
+ {
+ tree offs = gfc_conv_descriptor_offset_get (src);
+ for (int dim = 0; dim < src_rank; ++dim)
+ {
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+ }
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[0]);
+ for (int dim = 0; dim < dest_rank; ++dim)
+ {
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (as.lower[dim] && as.upper[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, as.lower[dim]);
+ gfc_conv_expr (&upper_se, as.upper[dim]);
+
+ gfc_add_block_to_block (block, &lower_se.pre);
+ gfc_add_block_to_block (block, &upper_se.pre);
+
+ tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, block);
+ ubound = gfc_evaluate_now (ubound, block);
+
+ gfc_add_block_to_block (block, &lower_se.post);
+ gfc_add_block_to_block (block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree offs = gfc_conv_descriptor_offset_get (dest);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ offs = gfc_evaluate_now (offs, block);
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ }
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ gfc_conv_remap_descriptor (block, dest, src, src_rank, as);
+}
+
+
static bool
keep_descriptor_lower_bound (gfc_expr *e)
{
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5dff9692f0ba..c50b1e05cdbd 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -829,8 +829,8 @@ gfc_get_vptr_from_expr (tree expr)
}
-static int
-descriptor_rank (tree descriptor)
+int
+gfc_descriptor_rank (tree descriptor)
{
tree dim = gfc_get_descriptor_dimension (descriptor);
tree dim_type = TREE_TYPE (dim);
@@ -850,8 +850,8 @@ void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
{
- int lhs_rank = descriptor_rank (lhs_desc);
- int rhs_rank = descriptor_rank (rhs_desc);
+ int lhs_rank = gfc_descriptor_rank (lhs_desc);
+ int rhs_rank = gfc_descriptor_rank (rhs_desc);
tree desc;
if (assumed_rank_lhs || lhs_rank == rhs_rank)
@@ -908,8 +908,8 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
tmp = gfc_get_descriptor_dimension (lhs_desc);
tmp2 = gfc_get_descriptor_dimension (rhs_desc);
- int rank = descriptor_rank (lhs_desc);
- int rank2 = descriptor_rank (rhs_desc);
+ int rank = gfc_descriptor_rank (lhs_desc);
+ int rank2 = gfc_descriptor_rank (rhs_desc);
if (rank == GFC_MAX_DIMENSIONS && rank2 != GFC_MAX_DIMENSIONS)
type = TREE_TYPE (tmp2);
else if (rank2 == GFC_MAX_DIMENSIONS && rank != GFC_MAX_DIMENSIONS)
@@ -11134,7 +11134,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
/* If we do bounds remapping, update LHS descriptor accordingly. */
if (remap)
{
- int dim;
gcc_assert (remap->u.ar.dimen == expr1->rank);
if (rank_remap)
@@ -11142,115 +11141,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
/* Do rank remapping. We already have the RHS's descriptor
converted in rse and now have to build the correct LHS
descriptor for it. */
-
- tree dtype, data, span;
- tree offs, stride;
- tree lbound, ubound;
-
- /* Set dtype. */
- dtype = gfc_conv_descriptor_dtype (desc);
- tmp = gfc_get_dtype (TREE_TYPE (desc));
- gfc_add_modify (&block, dtype, tmp);
-
- /* Copy data pointer. */
- data = gfc_conv_descriptor_data_get (rse.expr);
- gfc_conv_descriptor_data_set (&block, desc, data);
-
- /* Copy the span. */
- if (VAR_P (rse.expr)
- && GFC_DECL_PTR_ARRAY_P (rse.expr))
- span = gfc_conv_descriptor_span_get (rse.expr);
- else
- {
- tmp = TREE_TYPE (rse.expr);
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
- span = fold_convert (gfc_array_index_type, tmp);
- }
- gfc_conv_descriptor_span_set (&block, desc, span);
-
- /* Copy offset but adjust it such that it would correspond
- to a lbound of zero. */
- if (expr2->rank == -1)
- gfc_conv_descriptor_offset_set (&block, desc,
- gfc_index_zero_node);
- else
- {
- offs = gfc_conv_descriptor_offset_get (rse.expr);
- for (dim = 0; dim < expr2->rank; ++dim)
- {
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[dim]);
- lbound = gfc_conv_descriptor_lbound_get (rse.expr,
- gfc_rank_cst[dim]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride,
- lbound);
- offs = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offs, tmp);
- }
- gfc_conv_descriptor_offset_set (&block, desc, offs);
- }
- /* Set the bounds as declared for the LHS and calculate strides as
- well as another offset update accordingly. */
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[0]);
- for (dim = 0; dim < expr1->rank; ++dim)
- {
- gfc_se lower_se;
- gfc_se upper_se;
-
- gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
-
- if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
- || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
- gfc_resolve_expr (remap->u.ar.start[dim]);
- if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
- || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
- gfc_resolve_expr (remap->u.ar.end[dim]);
-
- /* Convert declared bounds. */
- gfc_init_se (&lower_se, NULL);
- gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
- gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
-
- gfc_add_block_to_block (&block, &lower_se.pre);
- gfc_add_block_to_block (&block, &upper_se.pre);
-
- lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, &block);
- ubound = gfc_evaluate_now (ubound, &block);
-
- gfc_add_block_to_block (&block, &lower_se.post);
- gfc_add_block_to_block (&block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (&block, desc,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (&block, desc,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, &block);
- gfc_conv_descriptor_stride_set (&block, desc,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- offs = gfc_conv_descriptor_offset_get (desc);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, &block);
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, tmp);
- }
+ gfc_conv_remap_descriptor (&block, desc, rse.expr, expr2->rank,
+ remap->u.ar);
}
else
/* Bounds remapping. Just shift the lower bounds. */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2ad3a98cf4f6..098fb07c1483 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -466,6 +466,8 @@ bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *,
bool);
void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
+void gfc_conv_remap_descriptor (stmtblock_t *, tree, tree, int, const
gfc_array_ref &);
+int gfc_descriptor_rank (tree);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
bool, bool, const char *, tree * = nullptr);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
