[gcc(refs/users/mikael/heads/refactor_descriptor_v08)] Extraction gfc_set_gfc_from_cfi
Mikael Morin
mikael@gcc.gnu.org
Sat Sep 6 14:56:44 GMT 2025
https://gcc.gnu.org/g:be565a7a832f44d5195746544441565b2292a008
commit be565a7a832f44d5195746544441565b2292a008
Author: Mikael Morin <mikael@gcc.gnu.org>
Date: Tue Jul 22 12:17:50 2025 +0200
Extraction gfc_set_gfc_from_cfi
Diff:
---
gcc/fortran/trans-descriptor.cc | 99 +++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-descriptor.h | 3 ++
gcc/fortran/trans-expr.cc | 92 +-------------------------------------
3 files changed, 103 insertions(+), 91 deletions(-)
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 28031526ad76..c8352f46c6c7 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -1793,3 +1793,102 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc, tree ptr,
gfc_array_index_type, offset));
gfc_conv_descriptor_offset_set (block, desc, offset);
}
+
+
+void
+gfc_set_gfc_from_cfi (stmtblock_t *block, tree gfc, gfc_expr *e, tree rank,
+ tree gfc_strlen, tree cfi, gfc_symbol *fsym)
+{
+ stmtblock_t block2;
+ gfc_init_block (&block2);
+ if (e->rank == 0)
+ {
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_add_modify (block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
+ }
+ else
+ {
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (block, gfc, tmp);
+
+ if (fsym->attr.allocatable)
+ {
+ /* gfc->span = cfi->elem_len. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+ }
+ else
+ {
+ /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tree tmp2 = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, tmp, tmp2);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+ }
+ gfc_conv_descriptor_span_set (&block2, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (gfc, idx),
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_stride_get (gfc, idx),
+ gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ }
+
+ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+ {
+ tree tmp = fold_convert (gfc_charlen_type_node,
+ gfc_get_cfi_desc_elem_len (cfi));
+ if (e->ts.kind != 1)
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_charlen_type_node, tmp,
+ build_int_cst (gfc_charlen_type_node,
+ e->ts.kind));
+ gfc_add_modify (&block2, gfc_strlen, tmp);
+ }
+
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+}
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index 796fdc8452aa..f3741db7b307 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -132,4 +132,7 @@ void gfc_set_contiguous_descriptor (stmtblock_t *, tree, tree, tree);
void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
gfc_expr *, gfc_expr *, locus *);
+void gfc_set_gfc_from_cfi (stmtblock_t *, tree, gfc_expr *, tree, tree,
+ tree, gfc_symbol *);
+
#endif /* GFC_TRANS_DESCRIPTOR_H */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c4e01fbf32eb..ce35e09cf84c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6265,97 +6265,7 @@ done:
|| fsym->attr.intent == INTENT_IN)
goto post_call;
- gfc_init_block (&block2);
- if (e->rank == 0)
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
- }
- else
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_conv_descriptor_data_set (&block, gfc, tmp);
-
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi));
- tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
- gfc_array_index_type, tmp, tmp2);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, gfc_index_zero_node);
- tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
- }
- gfc_conv_descriptor_span_set (&block2, gfc, tmp);
-
- /* Calculate offset + set lbound, ubound and stride. */
- gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
- /* Loop: for (i = 0; i < rank; ++i). */
- tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
- /* Loop body. */
- stmtblock_t loop_body;
- gfc_init_block (&loop_body);
- /* gfc->dim[i].lbound = ... */
- tmp = gfc_get_cfi_dim_lbound (cfi, idx);
- gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (gfc, idx),
- gfc_index_one_node);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- gfc_get_cfi_dim_extent (cfi, idx), tmp);
- gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
- tmp = gfc_get_cfi_dim_sm (cfi, idx);
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type, tmp,
- fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi)));
- gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc, idx),
- gfc_conv_descriptor_lbound_get (gfc, idx));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_offset_get (gfc), tmp);
- gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
- /* Generate loop. */
- gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
- rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
- gfc_finish_block (&loop_body));
- }
-
- if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
- {
- tmp = fold_convert (gfc_charlen_type_node,
- gfc_get_cfi_desc_elem_len (cfi));
- if (e->ts.kind != 1)
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_charlen_type_node, tmp,
- build_int_cst (gfc_charlen_type_node,
- e->ts.kind));
- gfc_add_modify (&block2, gfc_strlen, tmp);
- }
-
- tmp = gfc_get_cfi_desc_base_addr (cfi),
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, null_pointer_node);
- tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
+ gfc_set_gfc_from_cfi (&block, gfc, e, rank, gfc_strlen, cfi, fsym);
post_call:
gfc_add_block_to_block (&block, &se.post);
More information about the Gcc-cvs
mailing list