Hi Andrew,
This is OK by me.
I attach a slightly edited version of the patch itself in the hope that it
will make the code a bit clearer.
Thanks and welcome!
Paul
On Mon, 27 Nov 2023 at 17:35, Andrew Jenner <and...@codesourcery.com> wrote:
> This is the second version of the patch - previous discussion at:
> https://gcc.gnu.org/pipermail/gcc-patches/2023-November/636671.html
>
> This patch adds the testcase from PR110415 and fixes the bug.
>
> The problem is that in a couple of places in trans_class_assignment in
> trans-expr.cc, we need to get the run-time size of the polymorphic
> object from the vtbl, but we are currently getting that vtbl from the
> lhs of the assignment rather than the rhs. This gives us the old value
> of the size but we need to pass the new size to __builtin_malloc and
> __builtin_realloc.
>
> I'm fixing this by adding a parameter to trans_class_vptr_len_assignment
> to retrieve the tree corresponding the vptr from the object on the rhs
> of the assignment, and then passing this where it is needed. In the case
> where trans_class_vptr_len_assignment returns NULL_TREE for the rhs vptr
> we use the lhs vptr as before.
>
> To get this to work I also needed to change the implementation of
> trans_class_vptr_len_assignment to create a temporary for the assignment
> in more circumstances. Currently, the "a = func()" assignment in MAIN__
> doesn't hit the "Create a temporary for complication expressions" case
> on line 9951 because "DECL_P (rse->expr)" is true - the expression has
> already been placed into a temporary. That means we don't hit the "if
> (temp_rhs ..." case on line 10038 and go on to get the vptr_expr from
> "gfc_lval_expr_from_sym (gfc_find_vtab (&re->ts))" on line 10057 which
> is the vtbl of the static type rather than the dynamic one from the rhs.
> So with this fix we create an extra temporary, but that should be
> optimised away in the middle-end so there should be no run-time effect.
>
> I'm not sure if this is the best way to fix this (the Fortran front-end
> is new territory for me) but I've verified that the testcase passes with
> this change, fails without it, and that the change does not introduce
> any FAILs when running the gfortran testcases on x86_64-pc-linux-gnu.
>
> After the previous submission, Tobias Burnus found a closely related
> problem and contributed testcases and a fix for it, which I have
> incorporated into this version of the patch. The problem in this case is
> with the __builtin_realloc call that is executed if one polymorphic
> variable is replaced by another. The return value of this call was being
> ignored rather than used to replace the pointer being reallocated.
>
> Is this OK for mainline, GCC 13 and OG13?
>
> Thanks,
>
> Andrew
>
> gcc/fortran/
> PR fortran/110415
> * trans-expr.cc (trans_class_vptr_len_assignment): Add
> from_vptrp parameter. Populate it. Don't check for DECL_P
> when deciding whether to create temporary.
> (trans_class_pointer_fcn, gfc_trans_pointer_assignment): Add
> NULL argument to trans_class_vptr_len_assignment calls.
> (trans_class_assignment): Get rhs_vptr from
> trans_class_vptr_len_assignment and use it for determining size
> for allocation/reallocation. Use return value from realloc.
>
> gcc/testsuite/
> PR fortran/110415
> * gfortran.dg/pr110415.f90: New test.
> * gfortran.dg/asan/pr110415-2.f90: New test.
> * gfortran.dg/asan/pr110415-3.f90: New test.
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 1b8be081a17..35b000bf8d5 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9892,7 +9892,9 @@ trans_get_upoly_len (stmtblock_t *block, gfc_expr *expr)
static tree
trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_expr * re, gfc_se *rse,
- tree * to_lenp, tree * from_lenp)
+ tree * to_lenp = NULL,
+ tree * from_lenp = NULL,
+ tree * from_vptrp = NULL)
{
gfc_se se;
gfc_expr * vptr_expr;
@@ -9900,12 +9902,15 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
tree class_expr = NULL_TREE;
+ tree from_vptr = NULL_TREE;
/* Create a temporary for complicated expressions. */
- if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
- && rse->expr != NULL_TREE && !DECL_P (rse->expr))
+ if (re->expr_type != EXPR_VARIABLE
+ && re->expr_type != EXPR_NULL
+ && rse->expr != NULL_TREE)
{
- if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ if (re->ts.type == BT_CLASS
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
class_expr = gfc_get_class_from_expr (rse->expr);
if (rse->loop)
@@ -9959,8 +9964,8 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
/* Get the vptr from the rhs expression only, when it is variable.
Functions are expected to be assigned to a temporary beforehand. */
vptr_expr = (re->expr_type == EXPR_VARIABLE && re->ts.type == BT_CLASS)
- ? gfc_find_and_cut_at_last_class_ref (re)
- : NULL;
+ ? gfc_find_and_cut_at_last_class_ref (re)
+ : NULL;
if (vptr_expr != NULL && vptr_expr->ts.type == BT_CLASS)
{
if (to_len != NULL_TREE)
@@ -10000,6 +10005,7 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
tmp = rse->expr;
se.expr = gfc_class_vptr_get (tmp);
+ from_vptr = se.expr;
if (UNLIMITED_POLY (re))
from_len = gfc_class_len_get (tmp);
@@ -10021,9 +10027,10 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
gfc_free_expr (vptr_expr);
gfc_add_block_to_block (block, &se.pre);
gcc_assert (se.post.head == NULL_TREE);
+ from_vptr = se.expr;
}
- gfc_add_modify (pre, lhs_vptr, fold_convert (TREE_TYPE (lhs_vptr),
- se.expr));
+ gfc_add_modify (pre, lhs_vptr,
+ fold_convert (TREE_TYPE (lhs_vptr), se.expr));
if (to_len != NULL_TREE)
{
@@ -10049,11 +10056,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
}
}
- /* Return the _len trees only, when requested. */
+ /* Return the _len and _vptr trees only, when requested. */
if (to_lenp)
*to_lenp = to_len;
if (from_lenp)
*from_lenp = from_len;
+ if (from_vptrp)
+ *from_vptrp = from_vptr;
return lhs_vptr;
}
@@ -10120,9 +10129,7 @@ trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
rse->expr = gfc_class_data_get (rse->expr);
else
{
- expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
- expr2, rse,
- NULL, NULL);
+ expr1_vptr = trans_class_vptr_len_assignment (block, expr1, expr2, rse);
gfc_add_block_to_block (block, &rse->pre);
tmp = gfc_create_var (TREE_TYPE (rse->expr), "ptrtemp");
gfc_add_modify (&lse->pre, tmp, rse->expr);
@@ -10197,8 +10204,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
- trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
- NULL);
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse);
lse.expr = gfc_class_data_get (lse.expr);
}
@@ -10326,8 +10332,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
strlen_rhs = rse.string_length;
if (expr1->ts.type == BT_CLASS)
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
- expr2, &rse,
- NULL, NULL);
+ expr2, &rse);
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
@@ -10343,8 +10348,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
rse.expr = NULL_TREE;
rse.string_length = strlen_rhs;
- trans_class_vptr_len_assignment (&block, expr1, expr2, &rse,
- NULL, NULL);
+ trans_class_vptr_len_assignment (&block, expr1, expr2, &rse);
}
if (remap == NULL)
@@ -10376,8 +10380,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
else
{
expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
- expr2, &rse, NULL,
- NULL);
+ expr2, &rse);
gfc_add_block_to_block (&block, &rse.pre);
tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp");
gfc_add_modify (&lse.pre, tmp, rse.expr);
@@ -11775,7 +11778,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
bool class_realloc)
{
- tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr, rhs_vptr;
vec<tree, va_gc> *args = NULL;
bool final_expr;
@@ -11799,7 +11802,9 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
- &from_len);
+ &from_len, &rhs_vptr);
+ if (rhs_vptr == NULL_TREE)
+ rhs_vptr = vptr;
/* Generate (re)allocation of the lhs. */
if (class_realloc)
@@ -11812,7 +11817,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
else
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
- size = gfc_vptr_size_get (vptr);
+ size = gfc_vptr_size_get (rhs_vptr);
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
@@ -11826,12 +11831,14 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
+ tmp = fold_convert (pvoid_type_node, class_han);
re = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- fold_convert (pvoid_type_node, class_han),
- size);
+ tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
+ re);
tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, vptr, old_vptr);
+ logical_type_node, rhs_vptr, old_vptr);
re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
tmp, re, build_empty_stmt (input_location));
gfc_add_expr_to_block (&re_alloc, re);
