https://gcc.gnu.org/g:3ef8eb042e3dba9788c4d8ae928859cdb8e596c7
commit 3ef8eb042e3dba9788c4d8ae928859cdb8e596c7
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Mar 17 16:56:34 2025 +0100
Extraction fonction gfc_set_descriptor_for_assign_realloc
Diff:
---
gcc/cgraphunit.cc | 1 +
gcc/fortran/trans-array.cc | 220 +--------------------------------------
gcc/fortran/trans-descriptor.cc | 222 ++++++++++++++++++++++++++++++++++++++++
gcc/fortran/trans-descriptor.h | 4 +
4 files changed, 230 insertions(+), 217 deletions(-)
diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index bac17ed378b0..5881ebdcfbd4 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -3289,6 +3289,7 @@ data_value::set_cst_at (unsigned dest_offset, unsigned
value_width,
enum value_type orig_type = classify (dest_offset, value_width);
wide_int dest_mask = wi::shifted_mask (dest_offset, value_width, false,
bit_width);
+ // TODO: invalidate existing address if any
gcc_assert (orig_type != VAL_ADDRESS);
if (orig_type != VAL_CONSTANT)
{
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 41069947c793..1c62e691d210 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10131,76 +10131,6 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl,
int rank,
}
-/* Returns the value of LBOUND for an expression. This could be broken out
- from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
- called by gfc_alloc_allocatable_for_assignment. */
-static tree
-get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
-{
- tree lbound;
- tree ubound;
- tree stride;
- tree cond, cond1, cond3, cond4;
- tree tmp;
- gfc_ref *ref;
-
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- {
- tmp = gfc_rank_cst[dim];
- lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
- ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
- stride = gfc_conv_descriptor_stride_get (desc, tmp);
- cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- ubound, lbound);
- cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- logical_type_node, cond3, cond1);
- cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- if (assumed_size)
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- tmp, build_int_cst (gfc_array_index_type,
- expr->rank - 1));
- else
- cond = logical_false_node;
-
- cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond3, cond4);
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond, cond1);
-
- return fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- lbound, gfc_index_one_node);
- }
-
- if (expr->expr_type == EXPR_FUNCTION)
- {
- /* A conversion function, so use the argument. */
- gcc_assert (expr->value.function.isym
- && expr->value.function.isym->conversion);
- expr = expr->value.function.actual->expr;
- }
-
- if (expr->expr_type == EXPR_VARIABLE)
- {
- tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->as
- && ref->next
- && ref->next->u.ar.type == AR_FULL)
- tmp = TREE_TYPE (ref->u.c.component->backend_decl);
- }
- return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
- }
-
- return gfc_index_one_node;
-}
-
-
/* Returns true if an expression represents an lhs that can be reallocated
on assignment. */
@@ -10399,7 +10329,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
gfc_array_info *linfo;
tree realloc_expr;
tree alloc_expr;
- tree size1;
tree size2;
tree elemsize1;
tree elemsize2;
@@ -10407,20 +10336,15 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
tree cond_null;
tree cond;
tree tmp;
- tree tmp2;
tree lbound;
tree ubound;
tree desc;
- tree old_desc;
tree desc2;
- tree offset;
+ tree old_desc;
tree jump_label1;
tree jump_label2;
- tree lbd;
tree class_expr2 = NULL_TREE;
int n;
- int dim;
- gfc_array_spec * as;
bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
&& gfc_caf_attr (expr1, true).codimension);
tree token;
@@ -10608,20 +10532,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
build_empty_stmt (input_location));
gfc_add_expr_to_block (&fblock, tmp);
- /* Get arrayspec if expr is a full array. */
- if (expr2 && expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym
- && expr2->value.function.isym->conversion)
- {
- /* For conversion functions, take the arg. */
- gfc_expr *arg = expr2->value.function.actual->expr;
- as = gfc_get_full_arrayspec_from_expr (arg);
- }
- else if (expr2)
- as = gfc_get_full_arrayspec_from_expr (expr2);
- else
- as = NULL;
-
/* If the lhs shape is not the same as the rhs jump to setting the
bounds and doing the reallocation....... */
for (n = 0; n < expr1->rank; n++)
@@ -10687,66 +10597,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
else
old_desc = NULL_TREE;
- /* Now modify the lhs descriptor and the associated scalarizer
- variables. F2003 7.4.1.3: "If variable is or becomes an
- unallocated allocatable variable, then it is allocated with each
- deferred type parameter equal to the corresponding type parameters
- of expr , with the shape of expr , and with each lower bound equal
- to the corresponding element of LBOUND(expr)."
- Reuse size1 to keep a dimension-by-dimension track of the
- stride of the new array. */
- size1 = gfc_index_one_node;
- offset = gfc_index_zero_node;
-
- for (n = 0; n < expr2->rank; n++)
- {
- tmp = gfc_conv_array_extent_dim (loop->from[n], loop->to[n], NULL);
-
- lbound = gfc_index_one_node;
- ubound = tmp;
-
- if (as)
- {
- lbd = get_std_lbound (expr2, desc2, n,
- as->type == AS_ASSUMED_SIZE);
- ubound = fold_build2_loc (input_location,
- MINUS_EXPR,
- gfc_array_index_type,
- ubound, lbound);
- ubound = fold_build2_loc (input_location,
- PLUS_EXPR,
- gfc_array_index_type,
- ubound, lbd);
- lbound = lbd;
- }
-
- gfc_conv_descriptor_lbound_set (&fblock, desc,
- gfc_rank_cst[n],
- lbound);
- gfc_conv_descriptor_ubound_set (&fblock, desc,
- gfc_rank_cst[n],
- ubound);
- gfc_conv_descriptor_stride_set (&fblock, desc,
- gfc_rank_cst[n],
- size1);
- lbound = gfc_conv_descriptor_lbound_get (desc,
- gfc_rank_cst[n]);
- tmp2 = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- lbound, size1);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, tmp2);
- size1 = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- tmp, size1);
- }
-
- /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
- the array offset is saved and the info.offset is used for a
- running offset. Use the saved_offset instead. */
- gfc_conv_descriptor_offset_set (&fblock, desc, offset);
-
/* Take into account _len of unlimited polymorphic entities, so that span
for array descriptors and allocation sizes are computed correctly. */
if (UNLIMITED_POLY (expr2))
@@ -10760,9 +10610,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
fold_convert (gfc_array_index_type, len));
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
-
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
elemsize2, size2);
@@ -10771,69 +10618,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo
*loop,
size2, size_one_node);
size2 = gfc_evaluate_now (size2, &fblock);
- /* For deferred character length, the 'size' field of the dtype might
- have changed so set the dtype. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- tree type;
- if (expr2->ts.u.cl->backend_decl)
- type = gfc_typenode_for_spec (&expr2->ts);
- else
- type = gfc_typenode_for_spec (&expr1->ts);
-
- tree dtype_value = gfc_get_dtype_rank_type (expr1->rank, type);
- gfc_conv_descriptor_dtype_set (&fblock, desc, dtype_value);
- }
- else if (expr1->ts.type == BT_CLASS)
- {
- tree type;
- if (expr2->ts.type != BT_CLASS)
- type = gfc_typenode_for_spec (&expr2->ts);
- else
- type = gfc_get_character_type_len (1, elemsize2);
-
- tree dtype_value = gfc_get_dtype_rank_type (expr2->rank, type);
- gfc_conv_descriptor_dtype_set (&fblock, desc, dtype_value);
-
- /* Set the _len field as well... */
- if (UNLIMITED_POLY (expr1))
- {
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else if (UNLIMITED_POLY (expr2))
- gfc_add_modify (&fblock, tmp,
- gfc_class_len_get (TREE_OPERAND (desc2, 0)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- }
- /* ...and the vptr. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
- && TREE_CODE (desc2) == COMPONENT_REF)
- {
- tmp2 = gfc_get_class_from_expr (desc2);
- tmp2 = gfc_class_vptr_get (tmp2);
- }
- else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
- tmp2 = gfc_class_vptr_get (class_expr2);
- else
- {
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- }
-
- gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
- }
- else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- {
- gfc_conv_descriptor_dtype_set (&fblock, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
- }
+ gfc_set_descriptor_for_assign_realloc (&fblock, loop, expr1, expr2, desc,
+ desc2, elemsize2, class_expr2);
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index f6ffc55cccf3..dbc7f043e80f 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -3578,3 +3578,225 @@ gfc_copy_descriptor (stmtblock_t *block, tree dst, tree
src, int rank)
}
+/* Returns the value of LBOUND for an expression. This could be broken out
+ from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
+ called by gfc_alloc_allocatable_for_assignment. */
+static tree
+get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+{
+ tree lbound;
+ tree ubound;
+ tree stride;
+ tree cond, cond1, cond3, cond4;
+ tree tmp;
+ gfc_ref *ref;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ tmp = gfc_rank_cst[dim];
+ lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+ ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+ stride = gfc_conv_descriptor_stride_get (desc, tmp);
+ cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ ubound, lbound);
+ cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ stride, gfc_index_zero_node);
+ cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ logical_type_node, cond3, cond1);
+ cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+ stride, gfc_index_zero_node);
+ if (assumed_size)
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ tmp, build_int_cst (gfc_array_index_type,
+ expr->rank - 1));
+ else
+ cond = logical_false_node;
+
+ cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond3, cond4);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond, cond1);
+
+ return fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+
+ if (expr->expr_type == EXPR_FUNCTION)
+ {
+ /* A conversion function, so use the argument. */
+ gcc_assert (expr->value.function.isym
+ && expr->value.function.isym->conversion);
+ expr = expr->value.function.actual->expr;
+ }
+
+ if (expr->expr_type == EXPR_VARIABLE)
+ {
+ tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->as
+ && ref->next
+ && ref->next->u.ar.type == AR_FULL)
+ tmp = TREE_TYPE (ref->u.c.component->backend_decl);
+ }
+ return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+ }
+
+ return gfc_index_one_node;
+}
+
+
+void
+gfc_set_descriptor_for_assign_realloc (stmtblock_t *block, gfc_loopinfo *loop,
+ gfc_expr *expr1, gfc_expr *expr2,
+ tree desc, tree desc2, tree elemsize2,
+ tree class_expr2)
+{
+ bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
+ && gfc_caf_attr (expr1, true).codimension);
+
+ gfc_array_spec * as;
+ /* Get arrayspec if expr is a full array. */
+ if (expr2 && expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
+ && expr2->value.function.isym->conversion)
+ {
+ /* For conversion functions, take the arg. */
+ gfc_expr *arg = expr2->value.function.actual->expr;
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ }
+ else if (expr2)
+ as = gfc_get_full_arrayspec_from_expr (expr2);
+ else
+ as = NULL;
+
+ /* Modify the lhs descriptor and the associated scalarizer
+ variables. F2003 7.4.1.3: "If variable is or becomes an
+ unallocated allocatable variable, then it is allocated with each
+ deferred type parameter equal to the corresponding type parameters
+ of expr , with the shape of expr , and with each lower bound equal
+ to the corresponding element of LBOUND(expr)."
+ Reuse size1 to keep a dimension-by-dimension track of the
+ stride of the new array. */
+ tree size1 = gfc_index_one_node;
+ tree offset = gfc_index_zero_node;
+
+ for (int n = 0; n < expr2->rank; n++)
+ {
+ tree tmp = gfc_conv_array_extent_dim (loop->from[n], loop->to[n], NULL);
+
+ tree lbound = gfc_index_one_node;
+ tree ubound = tmp;
+
+ if (as)
+ {
+ tree lbd = get_std_lbound (expr2, desc2, n,
+ as->type == AS_ASSUMED_SIZE);
+ ubound = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbound);
+ ubound = fold_build2_loc (input_location,
+ PLUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbd);
+ lbound = lbd;
+ }
+
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[n],
+ lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[n],
+ ubound);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[n],
+ size1);
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ tree tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, size1);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp2);
+ tree size1 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, size1);
+ }
+
+ /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
+ the array offset is saved and the info.offset is used for a
+ running offset. Use the saved_offset instead. */
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ gfc_conv_descriptor_span_set (block, desc, elemsize2);
+
+ /* For deferred character length, the 'size' field of the dtype might
+ have changed so set the dtype. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ tree type;
+ if (expr2->ts.u.cl->backend_decl)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_typenode_for_spec (&expr1->ts);
+
+ tree dtype_value = gfc_get_dtype_rank_type (expr1->rank, type);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype_value);
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tree type;
+ if (expr2->ts.type != BT_CLASS)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_get_character_type_len (1, elemsize2);
+
+ tree dtype_value = gfc_get_dtype_rank_type (expr2->rank, type);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype_value);
+
+ /* Set the _len field as well... */
+ if (UNLIMITED_POLY (expr1))
+ {
+ tree tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (block, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (block, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
+ else
+ gfc_add_modify (block, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
+ /* ...and the vptr. */
+ tree tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tree tmp2;
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+ tmp2 = gfc_class_vptr_get (class_expr2);
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+ }
+ else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ gfc_conv_descriptor_dtype_set (block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
+}
+
+
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index cdc9b323afbf..353e33880c7a 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -112,4 +112,8 @@ gfc_class_array_data_assign (stmtblock_t *, tree, tree,
bool);
void
gfc_copy_descriptor (stmtblock_t *, tree, tree, int);
+void
+gfc_set_descriptor_for_assign_realloc (stmtblock_t *, gfc_loopinfo *,
+ gfc_expr *, gfc_expr *, tree, tree,
+ tree, tree);
