diff mbox series

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

Message ID 4e478077-4d4c-4e2f-8453-5fe77cf24b8b@codesourcery.com
State Accepted
Headers
Series Fortran: fix reallocation on assignment of polymorphic variables [PR110415] |

Checks

Context Check Description
snail/gcc-patch-check success Github commit url

Commit Message

Andrew Jenner Nov. 15, 2023, 4:51 p.m. UTC 
  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.

Is this OK for mainline, GCC 13 and OG13?

Thanks,

Andrew

gcc/fortran/
         * 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.

gcc/testsuite/
         * gfortran.dg/pr110415.f90: New test.
diff mbox series

Patch

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..f1618b55add 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9936,7 +9936,8 @@  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, tree * from_lenp,
+				 tree * from_vptrp)
 {
   gfc_se se;
   gfc_expr * vptr_expr;
@@ -9944,10 +9945,11 @@  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))
+      && rse->expr != NULL_TREE)
     {
       if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
 	class_expr = gfc_get_class_from_expr (rse->expr);
@@ -10044,6 +10046,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);
 
@@ -10065,6 +10068,7 @@  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));
@@ -10093,11 +10097,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;
 }
 
@@ -10166,7 +10172,7 @@  trans_class_pointer_fcn (stmtblock_t *block, gfc_se *lse, gfc_se *rse,
     {
       expr1_vptr = trans_class_vptr_len_assignment (block, expr1,
 						    expr2, rse,
-						    NULL, NULL);
+						    NULL, NULL, NULL);
       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);
@@ -10242,7 +10248,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);
+					   NULL, NULL);
 	  lse.expr = gfc_class_data_get (lse.expr);
 	}
 
@@ -10371,7 +10377,8 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	      if (expr1->ts.type == BT_CLASS)
 		expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
 							      expr2, &rse,
-							      NULL, NULL);
+							      NULL, NULL,
+							      NULL);
 	    }
 	}
       else if (expr2->expr_type == EXPR_VARIABLE)
@@ -10388,7 +10395,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);
+					       NULL, NULL, NULL);
 	    }
 
 	  if (remap == NULL)
@@ -10421,7 +10428,7 @@  gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	    {
 	      expr1_vptr = trans_class_vptr_len_assignment (&block, expr1,
 							    expr2, &rse, NULL,
-							    NULL);
+							    NULL, NULL);
 	      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);
@@ -11819,7 +11826,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;
 
@@ -11843,7 +11850,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)
@@ -11856,7 +11865,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;
@@ -11875,7 +11884,7 @@  trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
 				fold_convert (pvoid_type_node, class_han),
 				size);
       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);
diff --git a/gcc/testsuite/gfortran.dg/pr110415.f90 b/gcc/testsuite/gfortran.dg/pr110415.f90
new file mode 100644
index 00000000000..f647cc4c52c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr110415.f90
@@ -0,0 +1,20 @@ 
+! { dg-do run }
+!
+! Contributed by Brad Richardson <everythingfunctional@protonmail.com>
+!
+  type, abstract :: p
+  end type p
+
+  type, extends(p) :: c
+  end type c
+
+  class(p), allocatable :: a
+
+  a = func()
+contains
+  function func() result(a)
+    class(p), allocatable :: a
+
+    a = c()
+  end function func
+end program