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

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

[Paul Richard Thomas]

Fixed on 4.6 together with PR48746 in revision 173214.

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

	PR fortran/48462
	PR fortran/48746
	* trans-expr.c ( arrayfunc_assign_needs_temporary): Need a temp
	if automatic reallocation on assignement is active, the lhs is a
	target and the rhs an intrinsic function.
	(realloc_lhs_bounds_for_intrinsic_call): Rename as next.
	(fcncall_realloc_result): Renamed version of above function.
	Free the original descriptor data after the function call.Set the
bounds and the
	offset so that the lbounds are one.
	(gfc_trans_arrayfunc_assign): Call renamed function.

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

	PR fortran/48462
	PR fortran/48746
	* gfortran.dg/realloc_on_assign_7.f03: New test.

Paul

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

[Paul Richard Thomas]

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

This is the last of three regressions caused by my introduction of
reallocation on assignment.  The comments in the patch adequately
explain what is being done.

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

Paul

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

	PR fortran/48462
	* trans-expr.c (fcncall_realloc_result): Renamed version of
	realloc_lhs_bounds_for_intrinsic_call that does not touch the
	descriptor bounds anymore but makes a temporary descriptor to
	hold the result.
	(gfc_trans_arrayfunc_assign): Modify the reference to above
	renamed function.

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

	PR fortran/48462
	* gfortran.dg/realloc_on_assign_7.f03: New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-diff, Size: 5969 bytes --]

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 172607)
--- gcc/fortran/trans-expr.c	(working copy)
*************** realloc_lhs_loop_for_fcn_call (gfc_se *s
*** 5528,5582 ****
  }
  
  
  static void
! realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank)
  {
    tree desc;
    tree tmp;
-   tree offset;
-   int n;
  
!   /* Use the allocation done by the library.  */
    desc = build_fold_indirect_ref_loc (input_location, se->expr);
    tmp = gfc_conv_descriptor_data_get (desc);
    tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
!   gfc_add_expr_to_block (&se->pre, tmp);
!   gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node);
    /* Unallocated, the descriptor does not have a dtype.  */
    tmp = gfc_conv_descriptor_dtype (desc);
!   gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
! 
!   offset = gfc_index_zero_node;
!   tmp = gfc_index_one_node;
!   /* Now reset the bounds from zero based to unity based.  */
!   for (n = 0 ; n < rank; n++)
!     {
!       /* Accumulate the offset.  */
!       offset = fold_build2_loc (input_location, MINUS_EXPR,
! 				gfc_array_index_type,
! 				offset, tmp);
!       /* Now do the bounds.  */
!       gfc_conv_descriptor_offset_set (&se->post, desc, tmp);
!       tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
!       tmp = fold_build2_loc (input_location, PLUS_EXPR,
! 			     gfc_array_index_type,
! 			     tmp, gfc_index_one_node);
!       gfc_conv_descriptor_lbound_set (&se->post, desc,
! 				      gfc_rank_cst[n],
! 				      gfc_index_one_node);
!       gfc_conv_descriptor_ubound_set (&se->post, desc,
! 				      gfc_rank_cst[n], tmp);
! 
!       /* The extent for the next contribution to offset.  */
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]),
! 			     gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
!       tmp = fold_build2_loc (input_location, PLUS_EXPR,
! 			     gfc_array_index_type,
! 			     tmp, gfc_index_one_node);
!     }
!   gfc_conv_descriptor_offset_set (&se->post, desc, offset);
  }
  
  
--- 5528,5565 ----
  }
  
  
+ /* For Assignment to a reallocatable lhs from intrinsic functions,
+    replace the se.expr (ie. the result) with a temporary descriptor.
+    Null the data field so that the library allocates space for the
+    result. Free the data of the original descriptor after the function,
+    in case it appears in an argument expression and transfer the
+    result to the original descriptor.  */
+ 
  static void
! fcncall_realloc_result (gfc_se *se)
  {
    tree desc;
+   tree res_desc;
    tree tmp;
  
!   /* Use the allocation done by the library.  Substitute the lhs
!      descriptor with a copy, whose data field is nulled.*/
    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);
+   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
+      it.  */
    tmp = gfc_conv_descriptor_data_get (desc);
    tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
!   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)));
  }
  
  
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 5646,5652 ****
  	  ss->is_alloc_lhs = 1;
  	}
        else
! 	realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank);
      }
  
    gfc_conv_function_expr (&se, expr2);
--- 5629,5635 ----
  	  ss->is_alloc_lhs = 1;
  	}
        else
! 	fcncall_realloc_result (&se);
      }
  
    gfc_conv_function_expr (&se, expr2);
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03	(revision 0)
***************
*** 0 ****
--- 1,51 ----
+ ! { dg-do run }
+ ! Check the fix for PR48462 in which the assignments involving matmul
+ ! seg faulted because a was automatically freed before the assignment.
+ !
+ ! Contributed by John Nedney  <ortp21@gmail.com>
+ !
+ program main
+   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
+     if (any (delta > 1d-12)) call abort
+     if (any (lbound (a) .ne. [1, 1])) call abort
+   end subroutine
+ !
+ ! Check that all is well when the shape of 'a' changes.
+   subroutine bar
+     implicit none
+     real(kind=dp), allocatable :: a(:,:)
+     real(kind=dp), allocatable :: b(:,:)
+ 
+     b = reshape ([1d0, 1d0, 1d0], [3,1])
+     a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
+ 
+     a = matmul( a, matmul( a, b ) )
+ 
+     delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
+     if (any (delta > 1d-12)) call abort
+     if (any (lbound (a) .ne. [1, 1])) call abort
+   end subroutine
+ end program main
+