Re: [PATCH, Fortran, alloc_poly, v2] Fix allocation of memory for polymorphic assignment

[Andre Vehreschild <vehre at gmx dot de>]

Hi Janus, hi all,

thanks for the review. Committed as r243909.

Regards,
	Andre

On Thu, 22 Dec 2016 23:26:19 +0100
Janus Weil <janus@gcc.gnu.org> wrote:

> 2016-12-20 17:07 GMT+01:00 Andre Vehreschild <vehre@gmx.de>:
> > Hi Janus,
> >  
> >> 1) After adding that code block in gfc_trans_assignment_1, it seems
> >> like the comment above is outdated, right?  
> >
> > Thanks for noting.
> >  
> >> 2) Wouldn't it be better to move this block, which does the correct
> >> allocation for CLASS variables, into
> >> "alloc_scalar_allocatable_for_assignment", where the allocation for
> >> all other cases is done?  
> >
> > I tried to, but that would have meant to extend the interface of
> > alloc_scalar_allocatable_for_assignment significantly, while at the location
> > where I finally added the code, I could use the data available. Secondly
> > putting the malloc at the correct location is not possible at
> > alloc_scalar_... because the pre-blocks have already been joined to the
> > body. That way the malloc was always placed either before even the vptr was
> > set, or after the data was copied. Both options were quite hazardous.
> >
> > I now went to add the allocation into trans_class_assignment (). This allows
> > even more reuse of already present and needed data, e.g., the vptr.
> >
> > Bootstrapped and regtested ok on x86_64-linux/f23. Ok for trunk?  
> 
> Thanks for the explanations. The patch is ok with me in this form.
> 
> Cheers,
> Janus


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 243908)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -9625,18 +9625,39 @@
 
 static tree
 trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
-			gfc_se *lse, gfc_se *rse, bool use_vptr_copy)
+			gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
+			bool class_realloc)
 {
-  tree tmp;
-  tree fcn;
-  tree stdcopy, to_len, from_len;
+  tree tmp, fcn, stdcopy, to_len, from_len, vptr;
   vec<tree, va_gc> *args = NULL;
 
-  tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
+  vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
 					 &from_len);
 
-  fcn = gfc_vptr_copy_get (tmp);
+  /* Generate allocation of the lhs.  */
+  if (class_realloc)
+    {
+      stmtblock_t alloc;
+      tree class_han;
 
+      tmp = gfc_vptr_size_get (vptr);
+      class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+	  ? gfc_class_data_get (lse->expr) : lse->expr;
+      gfc_init_block (&alloc);
+      gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+      tmp = fold_build2_loc (input_location, EQ_EXPR,
+			     boolean_type_node, class_han,
+			     build_int_cst (prvoid_type_node, 0));
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+			     gfc_unlikely (tmp,
+					   PRED_FORTRAN_FAIL_ALLOC),
+			     gfc_finish_block (&alloc),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&lse->pre, tmp);
+    }
+
+  fcn = gfc_vptr_copy_get (vptr);
+
   tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
       ? gfc_class_data_get (rse->expr) : rse->expr;
   if (use_vptr_copy)
@@ -9961,15 +9982,10 @@
     }
 
   if (is_poly_assign)
-    {
-      tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
-				    use_vptr_copy || (lhs_attr.allocatable
-						      && !lhs_attr.dimension));
-      /* Modify the expr1 after the assignment, to allow the realloc below.
-	 Therefore only needed, when realloc_lhs is enabled.  */
-      if (flag_realloc_lhs && !lhs_attr.pointer)
-	gfc_add_data_component (expr1);
-    }
+    tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+				  use_vptr_copy || (lhs_attr.allocatable
+						    && !lhs_attr.dimension),
+				  flag_realloc_lhs && !lhs_attr.pointer);
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
 	   && ((lhs_caf_attr.allocatable && lhs_refs_comp)
@@ -10011,7 +10027,8 @@
   if (lss == gfc_ss_terminator)
     {
       /* F2003: Add the code for reallocation on assignment.  */
-      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
+      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
+	  && !is_poly_assign)
 	alloc_scalar_allocatable_for_assignment (&block, string_length,
 						 expr1, expr2);
 
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog	(Revision 243908)
+++ gcc/fortran/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,10 @@
+2016-12-23  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	* trans-expr.c (trans_class_assignment): Allocate memory of _vptr->size
+        before assigning an allocatable class object.
+	(gfc_trans_assignment_1): Flag that (re-)alloc of the class object
+	shall be done.
+
 2016-12-21  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/78866
Index: gcc/testsuite/gfortran.dg/class_assign_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/class_assign_1.f08	(nicht existent)
+++ gcc/testsuite/gfortran.dg/class_assign_1.f08	(Revision 243909)
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Check that reallocation of the lhs is done with the correct memory size.
+
+
+module base_mod
+
+  type, abstract :: base
+  contains
+    procedure(base_add), deferred :: add
+    generic :: operator(+) => add
+  end type base
+
+  abstract interface
+    module function base_add(l, r) result(res)
+      class(base), intent(in) :: l
+      integer, intent(in) :: r
+      class(base), allocatable :: res
+    end function base_add
+  end interface
+
+contains
+
+  subroutine foo(x)
+    class(base), intent(inout), allocatable :: x
+    class(base), allocatable :: t
+
+    t = x + 2
+    x = t + 40
+  end subroutine foo
+
+end module base_mod
+
+module extend_mod
+  use base_mod
+
+  type, extends(base) :: extend
+    integer :: i
+  contains
+    procedure :: add
+  end type extend
+
+contains
+  module function add(l, r) result(res)
+    class(extend), intent(in) :: l
+    integer, intent(in) :: r
+    class(base), allocatable :: res
+    select type (l)
+      class is (extend)
+        res = extend(l%i + r)
+      class default
+        error stop "Unkown class to add to."
+    end select
+  end function
+end module extend_mod
+
+program test_poly_ass
+  use extend_mod
+  use base_mod
+
+  class(base), allocatable :: obj
+  obj = extend(0)
+  call foo(obj)
+  select type (obj)
+    class is (extend)
+      if (obj%i /= 42) error stop
+    class default
+      error stop "Result's type wrong."
+  end select
+end program test_poly_ass
+
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog	(Revision 243908)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,3 +1,7 @@
+2016-12-23  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+	* gfortran.dg/class_assign_1.f08: New test.
+
 2016-12-23  Toma Tabacu  <toma.tabacu@imgtec.com>
 
 	* gcc.target/mips/oddspreg-2.c (dg-options): Remove dg-skip-if for