https://gcc.gnu.org/g:b7b0737f9d70a1415eedc9026932629ff025a5cb
commit b7b0737f9d70a1415eedc9026932629ff025a5cb
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Mar 14 15:40:09 2025 +0100
Factorisation set descriptor with shape
Diff:
---
gcc/fortran/trans-array.cc | 114 ++++++++++++++++++++++++++++++++++++++++-
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-intrinsic.cc | 108 ++------------------------------------
3 files changed, 119 insertions(+), 105 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d0f00f96fc02..abc0bd8756f4 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1553,7 +1553,7 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
&& dest_ls->akind != src_ls->akind)
tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
else
- tmp1 = desc;
+ tmp1 = src;
/* Copy the descriptor for pointer assignments. */
gfc_add_modify (block, dest, tmp1);
@@ -1562,7 +1562,7 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
/* ....and set the span field. */
- tree tmp2
+ tree tmp2;
if (src_expr->ts.type == BT_CHARACTER)
tmp2 = gfc_conv_descriptor_span_get (src);
else
@@ -1571,6 +1571,116 @@ copy_descriptor (stmtblock_t *block, tree dest, tree
src,
}
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc, tree ptr,
+ gfc_expr *shape, gfc_expr *lower, locus *where)
+{
+ /* Set the span field. */
+ tree tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (block, desc, tmp);
+
+ /* Set data value, dtype, and offset. */
+ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ gfc_ss *shape_ss = gfc_walk_expr (shape);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_se shapese, lowerse;
+ gfc_init_se (&shapese, nullptr);
+ gfc_ss *lower_ss = nullptr;
+ if (lower)
+ {
+ lower_ss = gfc_walk_expr (lower);
+ gcc_assert (lower_ss != gfc_ss_terminator);
+ gfc_init_se (&lowerse, nullptr);
+ }
+
+ gfc_loopinfo loop;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ if (lower)
+ gfc_add_ss_to_loop (&loop, lower_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+ if (lower)
+ gfc_mark_ss_chain_used (lower_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+ if (lower)
+ {
+ gfc_copy_loopinfo_to_se (&lowerse, &loop);
+ lowerse.ss = lower_ss;
+ }
+
+ tree stride = gfc_create_var (gfc_array_index_type, "stride");
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, stride, gfc_index_one_node);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ stmtblock_t body;
+ gfc_start_scalarized_body (&loop, &body);
+
+ tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ tree lbound;
+ if (lower)
+ {
+ gfc_conv_expr (&lowerse, lower);
+ gfc_add_block_to_block (&body, &lowerse.pre);
+ lbound = fold_convert (gfc_array_index_type, lowerse.expr);
+ gfc_add_block_to_block (&body, &lowerse.post);
+ }
+ else
+ lbound = gfc_index_one_node;
+
+ /* Set bounds and stride. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
+ gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+ gfc_conv_expr (&shapese, shape);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ tree ubound = fold_build2_loc (
+ input_location, MINUS_EXPR, gfc_array_index_type,
+ fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
+ fold_convert (gfc_array_index_type, shapese.expr)),
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, lbound);
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, tmp));
+
+ /* Update stride. */
+ gfc_add_modify (
+ &body, stride,
+ fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type, shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (block, &loop.pre);
+ gfc_add_block_to_block (block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e48f72856f6a..a1d6bbeef98a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -144,6 +144,8 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, tree);
void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+ gfc_expr *, gfc_expr *, locus *);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 895e2b0627be..c5632eb6d96d 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9919,11 +9919,9 @@ static tree
conv_isocbinding_subroutine (gfc_code *code)
{
gfc_expr *cptr, *fptr, *shape, *lower;
- gfc_se se, cptrse, fptrse, shapese, lowerse;
- gfc_ss *shape_ss, *lower_ss;
- tree desc, dim, tmp, stride, offset, lbound, ubound;
- stmtblock_t body, block;
- gfc_loopinfo loop;
+ gfc_se se, cptrse, fptrse;
+ tree desc;
+ stmtblock_t block;
gfc_actual_arglist *arg;
arg = code->ext.actual;
@@ -9965,106 +9963,10 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
- /* Set the span field. */
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (&block, desc, tmp);
-
- /* Set data value, dtype, and offset. */
- tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
- gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype (TREE_TYPE (desc)));
-
- /* Start scalarization of the bounds, using the shape argument. */
-
- shape_ss = gfc_walk_expr (shape);
- gcc_assert (shape_ss != gfc_ss_terminator);
- gfc_init_se (&shapese, NULL);
- if (lower)
- {
- lower_ss = gfc_walk_expr (lower);
- gcc_assert (lower_ss != gfc_ss_terminator);
- gfc_init_se (&lowerse, NULL);
- }
-
- gfc_init_loopinfo (&loop);
- gfc_add_ss_to_loop (&loop, shape_ss);
- if (lower)
- gfc_add_ss_to_loop (&loop, lower_ss);
- gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &fptr->where);
- gfc_mark_ss_chain_used (shape_ss, 1);
- if (lower)
- gfc_mark_ss_chain_used (lower_ss, 1);
-
- gfc_copy_loopinfo_to_se (&shapese, &loop);
- shapese.ss = shape_ss;
- if (lower)
- {
- gfc_copy_loopinfo_to_se (&lowerse, &loop);
- lowerse.ss = lower_ss;
- }
+ gfc_set_descriptor_with_shape (&block, desc, cptrse.expr,
+ shape, lower, &fptr->where);
- stride = gfc_create_var (gfc_array_index_type, "stride");
- offset = gfc_create_var (gfc_array_index_type, "offset");
- gfc_add_modify (&block, stride, gfc_index_one_node);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
-
- /* Loop body. */
- gfc_start_scalarized_body (&loop, &body);
-
- dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- loop.loopvar[0], loop.from[0]);
-
- if (lower)
- {
- gfc_conv_expr (&lowerse, lower);
- gfc_add_block_to_block (&body, &lowerse.pre);
- lbound = fold_convert (gfc_array_index_type, lowerse.expr);
- gfc_add_block_to_block (&body, &lowerse.post);
- }
- else
- lbound = gfc_index_one_node;
-
- /* Set bounds and stride. */
- gfc_conv_descriptor_lbound_set (&body, desc, dim, lbound);
- gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
-
- gfc_conv_expr (&shapese, shape);
- gfc_add_block_to_block (&body, &shapese.pre);
- ubound = fold_build2_loc (
- input_location, MINUS_EXPR, gfc_array_index_type,
- fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, lbound,
- fold_convert (gfc_array_index_type, shapese.expr)),
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&body, desc, dim, ubound);
- gfc_add_block_to_block (&body, &shapese.post);
-
- /* Calculate offset. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- stride, lbound);
- gfc_add_modify (&body, offset,
- fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offset, tmp));
-
- /* Update stride. */
- gfc_add_modify (
- &body, stride,
- fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride,
- fold_convert (gfc_array_index_type, shapese.expr)));
- /* Finish scalarization loop. */
- gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
- gfc_cleanup_loop (&loop);
-
- gfc_add_modify (&block, offset,
- fold_build1_loc (input_location, NEGATE_EXPR,
- gfc_array_index_type, offset));
- gfc_conv_descriptor_offset_set (&block, desc, offset);
-
gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
