[Patch, fortran] PR56008 (and PR47517) [F03] wrong code with lhs-realloc on assignment with derived types having allocatable components

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

[-- Attachment #1: Type: text/plain, Size: 1382 bytes --]

Dear All,

This patch is sufficiently straightforward that the ChangeLog entry
describes it completely.  The fix for both bugs lay in the
nullification of the allocatable components of the newly (re)allocated
array.  The deallocation of allocatable components plugged the
massive(10Mbytes) memory leak in the PR47517 testcase, flagged up by
Dominique (thanks!).

There is still a memory leak of about 1.8kbytes for
realloc_on_assign_17.f90.  This is PR38319 - ***sigh*** its assigned
to me.  I'll finally have a stab at it after a few more regression
fixes.

I believe that this patch is consistent with the release schedule
since it is a more or less 'obvious' fix to a bad code problem.  I
have included the release managers to get an OK from them.

Bootstrapped and regtested on x86_64/FC17 - OK for trunk?

Paul

2013-01-22  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/56008
    PR fortran/47517
    * trans-array.c (gfc_alloc_allocatable_for_assignment): Save
    the lhs descriptor before it is modified for reallocation. Use
    it to deallocate allocatable components in the reallocation
    block.  Nullify allocatable components for newly (re)allocated
    arrays.

2013-01-22  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/56008
    * gfortran.dg/realloc_on _assign_16.f90 : New test.

    PR fortran/47517
    * gfortran.dg/realloc_on _assign_17.f90 : New test.

[-- Attachment #2: submit.diff --]
[-- Type: application/octet-stream, Size: 5163 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 195244)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 7941,7946 ****
--- 7941,7947 ----
    tree lbound;
    tree ubound;
    tree desc;
+   tree old_desc;
    tree desc2;
    tree offset;
    tree jump_label1;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8091,8096 ****
--- 8092,8104 ----
  			  size1, size2);
    neq_size = gfc_evaluate_now (cond, &fblock);
  
+   /* Deallocation of allocatable components will have to occur on
+      reallocation.  Fix the old descriptor now.  */
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     old_desc = gfc_evaluate_now (desc, &fblock);
+   else
+     old_desc = NULL_TREE;
  
    /* Now modify the lhs descriptor and the associated scalarizer
       variables. F2003 7.4.1.3: "If variable is or becomes an
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8201,8212 ****
--- 8209,8238 ----
    /* Realloc expression.  Note that the scalarizer uses desc.data
       in the array reference - (*desc.data)[<element>]. */
    gfc_init_block (&realloc_block);
+ 
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, old_desc,
+ 				       expr1->rank);
+       gfc_add_expr_to_block (&realloc_block, tmp);
+     }
+ 
    tmp = build_call_expr_loc (input_location,
  			     builtin_decl_explicit (BUILT_IN_REALLOC), 2,
  			     fold_convert (pvoid_type_node, array1),
  			     size2);
    gfc_conv_descriptor_data_set (&realloc_block,
  				desc, tmp);
+ 
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ 				    expr1->rank);
+       gfc_add_expr_to_block (&realloc_block, tmp);
+     }
+ 
    realloc_expr = gfc_finish_block (&realloc_block);
  
    /* Only reallocate if sizes are different.  */
*************** gfc_alloc_allocatable_for_assignment (gf
*** 8224,8229 ****
--- 8250,8262 ----
  				desc, tmp);
    tmp = gfc_conv_descriptor_dtype (desc);
    gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+   if ((expr1->ts.type == BT_DERIVED)
+ 	&& expr1->ts.u.derived->attr.alloc_comp)
+     {
+       tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, desc,
+ 				    expr1->rank);
+       gfc_add_expr_to_block (&alloc_block, tmp);
+     }
    alloc_expr = gfc_finish_block (&alloc_block);
  
    /* Malloc if not allocated; realloc otherwise.  */
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_16.f90	(working copy)
***************
*** 0 ****
--- 1,28 ----
+ ! { dg-do run }
+ ! Test the fix for PR56008
+ !
+ ! Contributed by Stefan Mauerberger  <stefan.mauerberger@gmail.com>
+ !
+ PROGRAM main
+     !USE MPI
+ 
+     TYPE :: test_typ
+         REAL, ALLOCATABLE :: a(:)
+     END TYPE
+ 
+     TYPE(test_typ) :: xx, yy
+     TYPE(test_typ), ALLOCATABLE :: conc(:)
+ 
+     !CALL MPI_INIT(i)
+ 
+     xx = test_typ( [1.0,2.0] )
+     yy = test_typ( [4.0,4.9] )
+ 
+     conc = [ xx, yy ]
+ 
+     if (any (int (10.0*conc(1)%a) .ne. [10,20])) call abort
+     if (any (int (10.0*conc(2)%a) .ne. [40,49])) call abort
+ 
+     !CALL MPI_FINALIZE(i)
+ 
+ END PROGRAM main
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_17.f90	(working copy)
***************
*** 0 ****
--- 1,47 ----
+ ! { dg-do run }
+ ! Test the fix for PR47517
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ ! from a testcase by James Van Buskirk
+ module mytypes
+    implicit none
+    type label
+       integer, allocatable :: parts(:)
+    end type label
+    type table
+       type(label), allocatable :: headers(:)
+    end type table
+ end module mytypes
+ 
+ program allocate_assign
+    use mytypes
+    implicit none
+    integer, parameter :: ik8 = selected_int_kind(18)
+    type(table) x1(2)
+    type(table) x2(3)
+    type(table), allocatable :: x(:)
+    integer i, j, k
+    integer(ik8) s
+    call foo
+    s = 0
+    do k = 1, 10000
+       x = x1
+       s = s+x(2)%headers(2)%parts(2)
+       x = x2
+       s = s+x(2)%headers(2)%parts(2)
+    end do
+    if (s .ne. 40000) call abort
+ contains
+ !
+ ! TODO - these assignments lose 1872 bytes on x86_64/FC17
+ ! This is PR38319
+ !
+    subroutine foo
+        x1 = [table([(label([(j,j=1,3)]),i=1,3)]), &
+              table([(label([(j,j=1,4)]),i=1,4)])]
+ 
+        x2 = [table([(label([(j,j=1,4)]),i=1,4)]), &
+              table([(label([(j,j=1,5)]),i=1,5)]), &
+              table([(label([(j,j=1,6)]),i=1,6)])]
+    end subroutine
+ end program allocate_assign