Re: [PATCH v2] Fortran: fix reallocation on assignment of polymorphic variables [PR110415]

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 3554 bytes --]

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 <andrew@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.

[-- Attachment #2: pr110415_prt.diff --]
[-- Type: text/x-patch, Size: 6919 bytes --]

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);