[Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Paul Richard Thomas]

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

Dear All,

These are both quite trivial fixes and can be understood from
ChangeLogs and comments in the patch.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.6?

Cheers

Paul

2011-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48462
	* trans-expr.c (arrayfunc_assign_needs_temporary): Deal with
	automatic reallocation when the lhs is a target.

	PR fortran/48462
	* trans-expr.c (fcncall_realloc_result): Make sure that the
	result dtype field is set before the function call.

2011-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48462
	* gfortran.dg/realloc_on_assign_7.f03: Modify to test for lhs
	being a target.

	PR fortran/48746
	* gfortran.dg/realloc_on_assign_7.f03: Add subroutine pr48746.

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

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 173130)
--- gcc/fortran/trans-expr.c	(working copy)
*************** arrayfunc_assign_needs_temporary (gfc_ex
*** 5444,5452 ****
      return true;
  
    /* If we have reached here with an intrinsic function, we do not
!      need a temporary.  */
    if (expr2->value.function.isym)
!     return false;
  
    /* If the LHS is a dummy, we need a temporary if it is not
       INTENT(OUT).  */
--- 5444,5455 ----
      return true;
  
    /* If we have reached here with an intrinsic function, we do not
!      need a temporary except in the particular case that reallocation
!      on assignment is active and the lhs is allocatable and a target.  */
    if (expr2->value.function.isym)
!     return (gfc_option.flag_realloc_lhs
! 	      && sym->attr.allocatable
! 	      && sym->attr.target);
  
    /* If the LHS is a dummy, we need a temporary if it is not
       INTENT(OUT).  */
*************** fcncall_realloc_result (gfc_se *se)
*** 5547,5552 ****
--- 5550,5558 ----
    desc = build_fold_indirect_ref_loc (input_location, se->expr);
    res_desc = gfc_evaluate_now (desc, &se->pre);
    gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
+   /* Unallocated, the descriptor does not have a dtype.  */
+   tmp = gfc_conv_descriptor_dtype (res_desc);
+   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
    se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
  
    /* Free the lhs after the function call and copy the result data to
*************** fcncall_realloc_result (gfc_se *se)
*** 5556,5565 ****
    gfc_add_expr_to_block (&se->post, tmp);
    tmp = gfc_conv_descriptor_data_get (res_desc);
    gfc_conv_descriptor_data_set (&se->post, desc, tmp);
- 
-   /* Unallocated, the descriptor does not have a dtype.  */
-   tmp = gfc_conv_descriptor_dtype (desc);
-   gfc_add_modify (&se->post, tmp, gfc_get_dtype (TREE_TYPE (desc)));
  }
  
  
--- 5562,5567 ----
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 173130)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(working copy)
***************
*** 1,6 ****
--- 1,8 ----
  ! { dg-do run }
  ! Check the fix for PR48462 in which the assignments involving matmul
  ! seg faulted because a was automatically freed before the assignment.
+ ! Since it is related, the test for the fix of PR48746 has been added
+ ! as a subroutine by that name.
  !
  ! Contributed by John Nedney  <ortp21@gmail.com>
  !
*************** program main
*** 8,30 ****
    implicit none
    integer, parameter :: dp = kind(0.0d0)
    real(kind=dp), allocatable :: delta(:,:)
    
    call foo
    call bar
  contains
  !
  ! Original reduced version from comment #2
    subroutine foo
      implicit none
-     real(kind=dp), allocatable :: a(:,:)
      real(kind=dp), allocatable :: b(:,:)
  
-     allocate(a(3,3))
      allocate(b(3,3))
      allocate(delta(3,3))
  
-     b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
      a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
  
      a = matmul( matmul( a, b ), b )
      delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
--- 10,41 ----
    implicit none
    integer, parameter :: dp = kind(0.0d0)
    real(kind=dp), allocatable :: delta(:,:)
+   real(kind=dp), allocatable, target :: a(:,:)
+   real(kind=dp), pointer :: aptr(:,:)
+ 
+   allocate(a(3,3))
+   aptr => a
    
    call foo
+   if (.not. associated (aptr, a)) call abort () ! reallocated to same size - remains associated
    call bar
+   if (.not. associated (aptr, a)) call abort () ! reallocated to smaller size - remains associated
+   call foobar
+   if (associated (aptr, a)) call abort () ! reallocated to larger size - disassociates
+ 
+   call pr48746
  contains
  !
  ! Original reduced version from comment #2
    subroutine foo
      implicit none
      real(kind=dp), allocatable :: b(:,:)
  
      allocate(b(3,3))
      allocate(delta(3,3))
  
      a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+     b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
  
      a = matmul( matmul( a, b ), b )
      delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
*************** contains
*** 47,51 ****
      if (any (delta > 1d-12)) call abort
      if (any (lbound (a) .ne. [1, 1])) call abort
    end subroutine
  end program main
- 
--- 58,81 ----
      if (any (delta > 1d-12)) call abort
      if (any (lbound (a) .ne. [1, 1])) call abort
    end subroutine
+   subroutine foobar
+     integer :: i
+     a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
+   end subroutine
+   subroutine pr48746
+ ! This is a further wrinkle on the original problem and came about
+ ! because the dtype field of the result argument, passed to matmul,
+ ! was not being set. This is needed by matmul for the rank.
+ !
+ ! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+ !
+     implicit none
+     integer, parameter :: m=10, n=12, count=4
+     real :: optmatmul(m, n)
+     real :: a(m, count), b(count, n), c(m, n)
+     real, dimension(:,:), allocatable :: tmp
+     call random_number(a)
+     call random_number(b)
+     tmp = matmul(a,b)
+   end subroutine
  end program main

Re: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Steve Kargl]

On Fri, Apr 29, 2011 at 06:55:11PM +0200, Paul Richard Thomas wrote:
> Dear All,
> 
> These are both quite trivial fixes and can be understood from
> ChangeLogs and comments in the patch.
> 
> Bootstrapped and regtested on FC9/x86_64 - OK for trunk and 4.6?

OK for both.

-- 
Steve

Re: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Thomas Koenig]

Dear Paul,

first, thanks for the patch.

There is one thing it does not appear to do correctly: It should
also set the dtype on the variable itself:

ig25@linux-fd1f:~/Krempel/H> cat mm.f90
program main
   implicit none
   integer, parameter :: m=10, n=12, count=4
   double precision :: a(m, count), b(count, n), c(m, n)
   double precision, dimension(:,:), allocatable :: tmp

   call random_number(a)
   call random_number(b)
   tmp = matmul(a,b)
   print *,tmp
end program main
ig25@linux-fd1f:~/Krempel/H> gfortran -fdump-tree-original mm.f90
ig25@linux-fd1f:~/Krempel/H> ./a.out
At line 10 of file mm.f90 (unit = 6, file = 'stdout')
Internal Error: list_formatted_write(): Bad type

Apparently, the dtype of tmp is never set:

ig25@linux-fd1f:~/Krempel/H> grep tmp mm.f90.003t.original
   struct array2_real(kind=8) tmp;
       tmp.data = 0B;
         D.1573 = tmp;
           D.1574 = (void *) tmp.data;
         tmp.data = D.1573.data;
         _gfortran_transfer_array_write (&dt_parm.4, &tmp, 8, 0);
       if (tmp.data != 0B)
           __builtin_free ((void *) tmp.data);
       tmp.data = 0B;

Regards,

	Thomas

Re: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Thomas Koenig]

Hello Paul,

there's another point: The sizes are also not set correctly.

ig25@linux-fd1f:~/Krempel/H> cat mm.f90
program main
   implicit none
   integer, parameter :: m=10, n=12, count=4
   double precision :: a(m, count), b(count, n), c(m, n)
   double precision, dimension(:,:), allocatable :: tmp

   call random_number(a)
   call random_number(b)
   tmp = matmul(a,b)
   print *,size(tmp,1)
   print *,size(tmp,2)
end program main
ig25@linux-fd1f:~/Krempel/H> gfortran mm.f90
ig25@linux-fd1f:~/Krempel/H> ./a.out
            1
            1
ig25@linux-fd1f:~/Krempel/H>

Re: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Paul Richard Thomas]

Dear Thomas,

> there's another point: The sizes are also not set correctly.

Oh dear, oh dear!  I am losing it in my old age. :-(

Thanks

Paul

Re: [Patch, fortran] PR48462 - [4.6/4.7 Regression] realloc on assignment: matmul Segmentation Fault with Allocatable Array + PR48746

[Paul Richard Thomas]

Committed revision 173213 as obvious (in fact it reverts to original
treatment of bounds).

2011-04-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48746
	* trans-expr.c (fcncall_realloc_result): Set the bounds and the
	offset so that the lbounds are one.
	(gfc_trans_arrayfunc_assign): Add rank to arguments of above.

2011-04-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48746
	* gfortran.dg/realloc_on_assign_7.f03: Test bounds.

Paul