On 20.02.23 12:15, Jakub Jelinek wrote:
On Mon, Feb 20, 2023 at 12:07:43PM +0100, Tobias Burnus wrote:
As mentioned in the TODO for 'deferred', I think we really want
to have NULL as upper value for the domain for the type, but that
requires literally hundred of changes to the compiler, which
I do not want to due during Stage 4, but that are eventually
required.* — In any case, this patch fixes some of the issues
in the meanwhile.
Yeah, the actual len can be in some type's lang_specific member.
Actually, I think it should be bound to the DECL and not to the TYPE,
i.e. lang_decl not type_lang.
I just see that, the latter already has a 'tree stringlen' (for I/O)
which probably could be reused for this purpose.
Anyway, for the patch for now, I'd probably instead of stripping
SAVE_EXPR overwrite the 2 sizes with newly built expressions.
What I now did. (Unchanged otherwise, except that I now also mention
GFC_DECL_STRING_LEN in the TODO.)
OK for mainline?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634
München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas
Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht
München, HRB 106955
Fortran: Avoid SAVE_EXPR for deferred-len char types
Using TYPE_SIZE/TYPE_SIZE_UNIT with deferred-length character variables,
i.e. 'character(len=:), allocatable/pointer' used a SAVE_EXPR, i.e. the
value on entry to the scope instead of the latest value.
Solution: Remove the SAVE_EXPR again in this case.
gcc/fortran/ChangeLog:
* trans-types.h (gfc_get_character_type, gfc_get_character_type_len,
(gfc_get_character_type_len_for_eltype): Add argument 'bool deferred'.
* trans-types.cc (gfc_get_character_type_len_for_eltype): Likewise;
remove the SAVE_EXPR for the type size for deferred string lengths.
(gfc_get_character_type_len, gfc_get_character_type): Add arg
and pass on.
(gfc_typenode_for_spec): Update call.
* trans-array.cc (gfc_trans_create_temp_array,
trans_array_constructor, gfc_conv_loop_setup, gfc_array_init_size,
gfc_alloc_allocatable_for_assignment): Likewise.
* trans-expr.cc (gfc_conv_substring, gfc_conv_concat_op,
gfc_add_interface_mapping, gfc_conv_procedure_call,
gfc_conv_statement_function, gfc_conv_string_parameter): Likewise.
* trans-intrinsic.cc (gfc_conv_intrinsic_transfer,
gfc_conv_intrinsic_repeat): Likewise.
* trans-stmt.cc (forall_make_variable_temp,
gfc_trans_assign_need_temp): Likewise.
gcc/fortran/trans-array.cc | 11 ++++++-----
gcc/fortran/trans-expr.cc | 15 ++++++++-------
gcc/fortran/trans-intrinsic.cc | 5 +++--
gcc/fortran/trans-stmt.cc | 7 ++++---
gcc/fortran/trans-types.cc | 39 ++++++++++++++++++++++++++++++---------
gcc/fortran/trans-types.h | 6 +++---
6 files changed, 54 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 63bd1ac573a..b0abdadc3f5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1480,7 +1480,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
/* Casting the data as a character of the dynamic length ensures that
assignment of elements works when needed. */
- eltype = gfc_get_character_type_len (1, elemsize);
+ eltype = gfc_get_character_type_len (1, elemsize, true);
}
memset (from, 0, sizeof (from));
@@ -2823,7 +2823,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
- type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length);
+ type = gfc_get_character_type_len (expr->ts.kind, ss_info->string_length,
+ expr->ts.deferred);
if (const_string)
type = build_pointer_type (type);
}
@@ -5492,7 +5493,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
tmp_ss_info->data.temp.type
= gfc_get_character_type_len_for_eltype
(TREE_TYPE (tmp_ss_info->data.temp.type),
- tmp_ss_info->string_length);
+ tmp_ss_info->string_length, false);
tmp = tmp_ss_info->data.temp.type;
memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
@@ -5737,7 +5738,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
tmp = fold_convert (gfc_charlen_type_node, tmp);
- type = gfc_get_character_type_len (expr->ts.kind, tmp);
+ type = gfc_get_character_type_len (expr->ts.kind, tmp, expr->ts.deferred);
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
}
@@ -10908,7 +10909,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
if (expr2->ts.type != BT_CLASS)
type = gfc_typenode_for_spec (&expr2->ts);
else
- type = gfc_get_character_type_len (1, elemsize2);
+ type = gfc_get_character_type_len (1, elemsize2, true);
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr2->rank,type));
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e85b53fae85..50f81ea8881 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2589,7 +2589,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
char *msg;
mpz_t length;
- type = gfc_get_character_type (kind, ref->u.ss.length);
+ type = gfc_get_character_type (kind, ref->u.ss.length, false);
type = build_pointer_type (type);
gfc_init_se (&start, se);
@@ -3709,7 +3709,7 @@ gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
- type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl, false);
len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
if (len == NULL_TREE)
{
@@ -4474,7 +4474,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
convert it to a boundless character type. */
else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
{
- tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
+ tmp = gfc_get_character_type_len (sym->ts.kind, NULL, sym->ts.deferred);
tmp = build_pointer_type (tmp);
if (sym->attr.pointer)
value = build_fold_indirect_ref_loc (input_location,
@@ -7614,7 +7614,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (ts.type == BT_CHARACTER)
{
/* Pass the string length. */
- type = gfc_get_character_type (ts.kind, ts.u.cl);
+ type = gfc_get_character_type (ts.kind, ts.u.cl, false);
type = build_pointer_type (type);
/* Emit a DECL_EXPR for the VLA type. */
@@ -8240,7 +8240,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
fsym->ts.u.cl->backend_decl
= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
- type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+ type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl, false);
temp_vars[n] = gfc_create_var (type, fsym->name);
arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
@@ -8289,7 +8289,7 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
|| tree_int_cst_lt (se->string_length,
sym->ts.u.cl->backend_decl))
{
- type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl);
+ type = gfc_get_character_type (sym->ts.kind, sym->ts.u.cl, false);
tmp = gfc_create_var (type, sym->name);
tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
gfc_trans_string_copy (&se->pre, sym->ts.u.cl->backend_decl, tmp,
@@ -10391,7 +10391,8 @@ gfc_conv_string_parameter (gfc_se * se)
if (TREE_CODE (type) == ARRAY_TYPE)
type = TREE_TYPE (type);
type = gfc_get_character_type_len_for_eltype (type,
- se->string_length);
+ se->string_length,
+ false);
type = build_pointer_type (type);
se->expr = gfc_build_addr_expr (type, se->expr);
}
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 21eeb12ca89..babe30898a0 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -8548,7 +8548,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
case BT_CHARACTER:
tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
mold_type = gfc_get_character_type_len (arg->expr->ts.kind,
- argse.string_length);
+ argse.string_length,
+ arg->expr->ts.deferred);
break;
case BT_CLASS:
tmp = gfc_class_vtab_size_get (argse.expr);
@@ -9325,7 +9326,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
fold_convert (gfc_charlen_type_node, slen),
fold_convert (gfc_charlen_type_node, ncopies));
- type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl, false);
dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
/* Generate the code to do the repeat operation:
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 2b4278be748..9a1caf56bcb 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -3895,7 +3895,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
{
tse.string_length = rse.string_length;
tmp = gfc_get_character_type_len (gfc_default_character_kind,
- tse.string_length);
+ tse.string_length, e->ts.deferred);
tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
rse.string_length);
gfc_add_block_to_block (pre, &tse.pre);
@@ -4676,7 +4676,7 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
gfc_init_se (&ssse, NULL);
gfc_conv_expr (&ssse, expr1);
type = gfc_get_character_type_len (gfc_default_character_kind,
- ssse.string_length);
+ ssse.string_length, false);
}
else
{
@@ -4689,7 +4689,8 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
expr1->ts.u.cl->backend_decl = tse.expr;
}
type = gfc_get_character_type_len (gfc_default_character_kind,
- expr1->ts.u.cl->backend_decl);
+ expr1->ts.u.cl->backend_decl,
+ false);
}
}
else
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 9c9489a42bd..a7e512a26cc 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1112,32 +1112,58 @@ gfc_get_pchar_type (int kind)
}
-/* Create a character type with the given kind and length. */
+/* Create a character type with the given kind and length; 'deferred' affects
+ the following: If 'len' is a variable/non-constant expression, it can be
+ either for
+
+ * a stack-allocated variable where the length is taken from the outside
+ ('VLA') (global variable, dummy argument, variable from before a BLOCK) - in
+ this case, the value on entry needs to be preserved -> SAVE_EXPR.
+
+ * or, 'len' is the hidden variable of a deferred-length ('len=:') variable,
+ such that the current value after the last pointer-assignment or allocation
+ must be used. In this case, there shall not be a SAVE_EXPR. */
tree
-gfc_get_character_type_len_for_eltype (tree eltype, tree len)
+gfc_get_character_type_len_for_eltype (tree eltype, tree len, bool deferred)
{
tree bounds, type;
bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
type = build_array_type (eltype, bounds);
TYPE_STRING_FLAG (type) = 1;
-
+ if (len && deferred && TREE_CODE (TYPE_SIZE (type)) == SAVE_EXPR)
+ {
+ /* TODO: A more middle-end friendly alternative would be to use NULL_TREE
+ as upper bound and store the value, e.g. as GFC_DECL_STRING_LEN.
+ Caveat: this requires some cleanup throughout the code to consistently
+ use some wrapper function. */
+ gcc_assert (TREE_CODE (TYPE_SIZE_UNIT (type)) == SAVE_EXPR);
+ tree tmp = TREE_TYPE (TYPE_SIZE (eltype));
+ TYPE_SIZE (type) = fold_build2_loc (input_location, MULT_EXPR, tmp,
+ TYPE_SIZE (eltype),
+ fold_convert (tmp, len));
+ tmp = TREE_TYPE (TYPE_SIZE_UNIT (eltype));
+ TYPE_SIZE_UNIT (type) = fold_build2_loc (input_location, MULT_EXPR, tmp,
+ TYPE_SIZE_UNIT (eltype),
+ fold_convert (tmp, len));
+ }
return type;
}
tree
-gfc_get_character_type_len (int kind, tree len)
+gfc_get_character_type_len (int kind, tree len, bool deferred)
{
gfc_validate_kind (BT_CHARACTER, kind, false);
- return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
+ return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len,
+ deferred);
}
/* Get a type node for a character kind. */
tree
-gfc_get_character_type (int kind, gfc_charlen * cl)
+gfc_get_character_type (int kind, gfc_charlen * cl, bool deferred)
{
tree len;
@@ -1145,7 +1171,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
if (len && POINTER_TYPE_P (TREE_TYPE (len)))
len = build_fold_indirect_ref (len);
- return gfc_get_character_type_len (kind, len);
+ return gfc_get_character_type_len (kind, len, deferred);
}
/* Convert a basic type. This will be an array for character types. */
@@ -1189,13 +1215,14 @@ gfc_typenode_for_spec (gfc_typespec * spec, int codim)
break;
case BT_CHARACTER:
- basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+ basetype = gfc_get_character_type (spec->kind, spec->u.cl,
+ spec->deferred);
break;
case BT_HOLLERITH:
/* Since this cannot be used, return a length one character. */
basetype = gfc_get_character_type_len (gfc_default_character_kind,
- gfc_index_one_node);
+ gfc_index_one_node, false);
break;
case BT_UNION:
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 2dc692325cf..b2a0375ddfa 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -81,9 +81,9 @@ tree gfc_get_complex_type (int);
tree gfc_get_logical_type (int);
tree gfc_get_char_type (int);
tree gfc_get_pchar_type (int);
-tree gfc_get_character_type (int, gfc_charlen *);
-tree gfc_get_character_type_len (int, tree);
-tree gfc_get_character_type_len_for_eltype (tree, tree);
+tree gfc_get_character_type (int, gfc_charlen *, bool);
+tree gfc_get_character_type_len (int, tree, bool);
+tree gfc_get_character_type_len_for_eltype (tree, tree, bool);
tree gfc_sym_type (gfc_symbol *, bool is_bind_c_arg = false);
tree gfc_get_cfi_type (int dimen, bool restricted);
