https://gcc.gnu.org/g:bcdea6ab6a4b8a0e200d143c5ec4c39ada487a41
commit bcdea6ab6a4b8a0e200d143c5ec4c39ada487a41
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Wed Feb 12 18:17:41 2025 +0100
Factorisation set temporary descriptor
Diff:
---
gcc/fortran/trans-array.cc | 104 +++++++++++++++++++++++++++++++++------------
1 file changed, 77 insertions(+), 27 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 051ccafe9807..fd6f9f56dcb1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3294,13 +3294,14 @@ gfc_set_loop_bounds_from_array_spec
(gfc_interface_mapping * mapping,
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
-static void
+static tree
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
gfc_array_info * info, tree size, tree nelem,
tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
+ tree ptr = NULL_TREE;
bool onstack;
desc = info->descriptor;
@@ -3308,7 +3309,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,
stmtblock_t * post,
if (size == NULL_TREE || (dynamic && integer_zerop (size)))
{
/* A callee allocated array. */
- gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+ ptr = null_pointer_node;
onstack = false;
}
else
@@ -3336,8 +3337,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,
stmtblock_t * post,
fold_build1_loc (input_location,
DECL_EXPR, TREE_TYPE (tmp),
tmp));
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- gfc_conv_descriptor_data_set (pre, desc, tmp);
+ ptr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
@@ -3345,7 +3345,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,
stmtblock_t * post,
if (initial == NULL_TREE)
{
tmp = gfc_call_malloc (pre, NULL, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ ptr = gfc_evaluate_now (tmp, pre);
}
else
{
@@ -3388,18 +3388,12 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,
stmtblock_t * post,
build_empty_stmt (input_location));
gfc_add_expr_to_block (pre, tmp);
- tmp = fold_convert (pvoid_type_node, packed);
+ ptr = fold_convert (pvoid_type_node, packed);
}
-
- gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
- /* The offset is zero because we create temporaries with a zero
- lower bound. */
- gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
-
if (dealloc && !onstack)
{
/* Free the temporary. */
@@ -3407,6 +3401,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre,
stmtblock_t * post,
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (post, tmp);
}
+
+ return ptr;
}
@@ -3618,6 +3614,63 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss,
tree *eltype,
}
+static void
+set_temporary_descriptor (stmtblock_t *block, tree desc, tree class_src,
+ tree elemsize, tree data_ptr,
+ tree ubound[GFC_MAX_DIMENSIONS],
+ tree stride[GFC_MAX_DIMENSIONS], int rank,
+ bool callee_allocated, bool rank_changer)
+{
+ tree class_expr = NULL_TREE;
+ int n;
+
+ if (!class_expr)
+ {
+ /* Fill in the array dtype. */
+ gfc_conv_descriptor_dtype_set (block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
+ else if (rank_changer)
+ {
+ /* For classes, we copy the whole original class descriptor to the
+ temporary one, so we don't need to set the individual dtype fields.
+ Except for the case of rank altering intrinsics for which we
+ generate descriptors of different rank. */
+
+ /* Take the dtype from the class expression. */
+ tree src_data = gfc_class_data_get (class_src);
+ tree dtype = gfc_conv_descriptor_dtype_get (src_data);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype);
+
+ /* These transformational functions change the rank. */
+ gfc_conv_descriptor_rank_set (block, desc, rank);
+ }
+
+ /* Set the span. */
+ gfc_conv_descriptor_span_set (block, desc, elemsize);
+
+ if (!callee_allocated)
+ {
+ for (n = 0; n < rank; n++)
+ {
+ /* Store the stride and bound components in the descriptor. */
+ gfc_conv_descriptor_stride_set (block, desc, gfc_rank_cst[n],
+ stride[n]);
+
+ gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[n],
+ gfc_index_zero_node);
+
+ gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[n],
ubound[n]);
+ }
+ }
+
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+
+ /* The offset is zero because we create temporaries with a zero
+ lower bound. */
+ gfc_conv_descriptor_offset_set (block, desc, gfc_index_zero_node);
+}
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
@@ -3645,7 +3698,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre,
stmtblock_t * post, gfc_ss * ss,
gfc_loopinfo *loop;
gfc_ss *s;
gfc_array_info *info;
- tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
+ tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS],
stride[GFC_MAX_DIMENSIONS];
tree type;
tree desc;
tree tmp;
@@ -3781,13 +3834,13 @@ gfc_trans_create_temp_array (stmtblock_t * pre,
stmtblock_t * post, gfc_ss * ss,
TREE_USED (desc) = 0;
}
+ bool rank_changer = false;
if (class_expr != NULL_TREE
|| (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
{
tree class_data;
tree dtype;
gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
- bool rank_changer;
/* Pick out these transformational functions because they change the rank
or shape of the first argument. This requires that the class type be
@@ -3847,10 +3900,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre,
stmtblock_t * post, gfc_ss * ss,
gfc_conv_descriptor_dtype_set (pre, desc, dtype);
/* These transformational functions change the rank. */
- tmp = gfc_conv_descriptor_rank_get (desc);
- gfc_conv_descriptor_rank_set (pre, desc,
- build_int_cst (TREE_TYPE (tmp),
- ss->loop->dimen));
+ gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
fcn_ss->info->class_container = NULL_TREE;
}
@@ -3916,13 +3966,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre,
stmtblock_t * post, gfc_ss * ss,
{
for (n = 0; n < total_dim; n++)
{
- /* Store the stride and bound components in the descriptor. */
- gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
-
- gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
- gfc_index_zero_node);
-
- gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
+ stride[n] = size;
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
@@ -3967,8 +4011,14 @@ gfc_trans_create_temp_array (stmtblock_t * pre,
stmtblock_t * post, gfc_ss * ss,
tmp = fold_convert (gfc_array_index_type, elemsize);
gfc_conv_descriptor_span_set (pre, desc, tmp);
- gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
- dynamic, dealloc);
+ tree data_ptr = gfc_trans_allocate_array_storage (pre, post, info, size,
+ nelem, initial, dynamic,
+ dealloc);
+
+ set_temporary_descriptor (pre, desc, class_expr, elemsize, data_ptr,
+ to, stride, total_dim,
+ size == NULL_TREE || callee_alloc,
+ rank_changer);
while (ss->parent)
ss = ss->parent;
