https://gcc.gnu.org/g:8fb40fe6608990cc67e827e9b9f2bf043cdce5cc
commit 8fb40fe6608990cc67e827e9b9f2bf043cdce5cc
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Tue Jan 21 22:27:02 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 117 ++++++++++++++++++++++++++++++++++++---------
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 82 ++-----------------------------
3 files changed, 100 insertions(+), 100 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b05f69fdd874..7afa29746e08 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1198,16 +1198,52 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
}
-class lb_info
+class lb_info_base
{
public:
+ virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+ using lb_info_base::lower_bound;
virtual gfc_expr *lower_bound (int dim) const = 0;
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
};
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+ gfc_expr *lb_expr = lower_bound(dim);
+
+ if (lb_expr == nullptr)
+ return gfc_index_one_node;
+ else
+ {
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+ gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ return lb_var;
+ }
+}
+
+
+
class unset_lb : public lb_info
{
public:
+ using lb_info::lower_bound;
virtual gfc_expr *lower_bound (int) const { return nullptr; }
};
@@ -1218,6 +1254,7 @@ class defined_lb : public lb_info
gfc_expr * const * lower_bounds;
public:
+ using lb_info::lower_bound;
defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
@@ -1226,7 +1263,7 @@ public:
static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
- const lb_info &info)
+ const lb_info_base &info)
{
tree tmp = gfc_conv_descriptor_offset_get (desc);
tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
@@ -1235,26 +1272,7 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
- gfc_expr *lb_expr = info.lower_bound(dim);
-
- tree lower_bound;
- if (lb_expr == nullptr)
- lower_bound = gfc_index_one_node;
- else
- {
- gfc_se lb_se;
-
- gfc_init_se (&lb_se, nullptr);
- gfc_conv_expr (&lb_se, lb_expr);
-
- gfc_add_block_to_block (block, &lb_se.pre);
- tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
- gfc_add_modify (block, lb_var, lb_se.expr);
- gfc_add_block_to_block (block, &lb_se.post);
-
- lower_bound = lb_var;
- }
-
+ tree lower_bound = info.lower_bound (block, dim);
conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
@@ -1337,6 +1355,61 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
}
+class dataref_lb : public lb_info_base
+{
+ gfc_array_spec *as;
+ gfc_expr *conv_arg;
+ tree desc;
+
+public:
+ dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+ : as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+ {}
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+ tree lbound;
+ if (as && as->lower[dim])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[dim]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+ }
+ else if (as && conv_arg)
+ {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ else
+ lbound = gfc_index_one_node;
+
+ return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+ gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+ as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+ as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as,
conv_arg, desc));
+}
+
+
void
gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
int src_rank, const gfc_array_spec &as)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 05ea68d531ac..f9988a5fd109 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -219,6 +219,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
+void gfc_conv_shift_descriptor_subarray (stmtblock_t*, tree, gfc_expr *,
gfc_expr *);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 65b6cd8a4642..84c30321d431 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9418,83 +9418,6 @@ gfc_trans_subarray_assign (tree dest, gfc_component *
cm, gfc_expr * expr)
}
-static void
-set_subarray_descriptor (stmtblock_t *block, tree desc, tree value,
- gfc_expr *value_expr, gfc_expr *conv_arg)
-{
- if (value_expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (block, value,
- null_pointer_node);
-
- /* Obtain the array spec of full array references. */
- gfc_array_spec *as;
- if (conv_arg)
- as = gfc_get_full_arrayspec_from_expr (conv_arg);
- else
- as = gfc_get_full_arrayspec_from_expr (value_expr);
-
- /* Shift the lbound and ubound of temporaries to being unity,
- rather than zero, based. Always calculate the offset. */
- tree offset = gfc_conv_descriptor_offset_get (desc);
- gfc_add_modify (block, offset, gfc_index_zero_node);
- tree tmp2 = gfc_create_var (gfc_array_index_type, NULL);
-
- for (int n = 0; n < value_expr->rank; n++)
- {
- tree span;
- tree lbound;
-
- /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
- TODO It looks as if gfc_conv_expr_descriptor should return
- the correct bounds and that the following should not be
- necessary. This would simplify gfc_conv_intrinsic_bound
- as well. */
- if (as && as->lower[n])
- {
- gfc_se lbse;
- gfc_init_se (&lbse, NULL);
- gfc_conv_expr (&lbse, as->lower[n]);
- gfc_add_block_to_block (block, &lbse.pre);
- lbound = gfc_evaluate_now (lbse.expr, block);
- }
- else if (as && conv_arg)
- {
- tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
- lbound = gfc_conv_descriptor_lbound_get (tmp,
- gfc_rank_cst[n]);
- }
- else if (as)
- lbound = gfc_conv_descriptor_lbound_get (desc,
- gfc_rank_cst[n]);
- else
- lbound = gfc_index_one_node;
-
- lbound = fold_convert (gfc_array_index_type, lbound);
-
- /* Shift the bounds and set the offset accordingly. */
- tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
- span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- span, lbound);
- gfc_conv_descriptor_ubound_set (block, desc,
- gfc_rank_cst[n], tmp);
- gfc_conv_descriptor_lbound_set (block, desc,
- gfc_rank_cst[n], lbound);
-
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (desc,
- gfc_rank_cst[n]),
- gfc_conv_descriptor_stride_get (desc,
- gfc_rank_cst[n]));
- gfc_add_modify (block, tmp2, tmp);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, tmp2);
- gfc_conv_descriptor_offset_set (block, desc, tmp);
- }
-}
-
-
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
@@ -9571,7 +9494,10 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
- set_subarray_descriptor (&block, dest, se.expr, expr, arg);
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
+
+ gfc_conv_shift_descriptor_subarray (&block, dest, expr, arg);
if (arg)
{
