Patchwork [fortran] PR47071 - [4.6 Regression] Wrong reallocate

login
register
mail settings
Submitter Paul Richard Thomas
Date Jan. 10, 2011, 5:38 a.m.
Message ID <AANLkTikH63dQEVM0+-gwjwZLH42zZv=3viEoZZ6dzTCO@mail.gmail.com>
Download mbox | patch
Permalink /patch/78077/
State New
Headers show

Comments

Paul Richard Thomas - Jan. 10, 2011, 5:38 a.m.
F2003 7.4.1.3
".....
   If variable is an allocated allocatable variable, it is deallocated
if expr is an array of different shape
   or any of the corresponding length type parameter values of
variable and expr differ. If variable is or
   becomes an unallocated allocatable variable, then it is allocated
with each deferred type parameter equal
   to the corresponding type parameters of expr , with the shape of
expr , and with each lower bound equal
   to the corresponding element of LBOUND(expr )."

This ensures that valid F95 code works as expected, since comforming
variable and expr should be assigned as if the variable were not
allocatable.

gfortran was testing only for size and not shape.  In addition, before
reallocation was done, the bounds were changed, regardless of the
shape.  This incorrect behaviour was reinforced by being identical to
that of another product.

Many thanks to Joost VandeVondele for reporting this.

The patch looks MUCH more complicated than it actually is.  The
required behaviour is obtained by moving chunks of code around and
eliminating the test for size.  I have added extra comments.  A
specific test is not needed since the correction to
realloc_on_assign.f03 covers it.

Note that we still have to deal with changing length parameters; eg.
character length or dynamic type.  Realistically, I think that this
will come in 4.7 but I will see what I can do:-)

Bootstraps and regtests on FC9/x86_64 - OK for trunk?

Paul

2011-01-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47051
	* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
	to be standard compliant by testing for shape rather than size
	before skipping reallocation. Improve comments.

2011-01-10  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/47051
	* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
	standard compliant and comment.
Tobias Burnus - Jan. 10, 2011, 10:12 a.m.
On 01/10/2011 06:38 AM, Paul Richard Thomas wrote:
> Note that we still have to deal with changing length parameters; eg.
> character length or dynamic type.  Realistically, I think that this
> will come in 4.7 but I will see what I can do:-)

(I personally would prefer to see first the implementation of reallocate 
on assignment for scalars.)

> Bootstraps and regtests on FC9/x86_64 - OK for trunk?

OK. Thanks for the patch!

Tobias

PS: As there is a quote, it is not really needed - but in general I 
prefer if references to the standard (constraint numbers or section 
numbers) also include the Fortran standard (F95, F(20)03, F(20)08).

> 2011-01-10  Paul Thomas<pault@gcc.gnu.org>
>
> 	PR fortran/47051
> 	* trans-array.c (gfc_alloc_allocatable_for_assignment): Change
> 	to be standard compliant by testing for shape rather than size
> 	before skipping reallocation. Improve comments.
>
> 2011-01-10  Paul Thomas<pault@gcc.gnu.org>
>
> 	PR fortran/47051
> 	* gfortran.dg/realloc_on_assign_2.f03 : Modify 'test1' to be
> 	standard compliant and comment.
Paul Richard Thomas - Jan. 11, 2011, 8:22 a.m.
Dear Tobias,

>
> OK. Thanks for the patch!
>
> Tobias
>

Thanks for the review.  It's fixed.

Author: pault
Date: Tue Jan 11 05:19:20 2011
New Revision: 168650

URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=168650

Paul

Patch

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 168599)
--- gcc/fortran/trans-array.c	(working copy)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 6877,6911 ****
    desc = lss->data.info.descriptor;
    gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
    array1 = gfc_conv_descriptor_data_get (desc);
-   size1 = gfc_conv_descriptor_size (desc, expr1->rank);
- 
-   /* Get the rhs size.  Fix both sizes.  */
-   if (expr2)
-     desc2 = rss->data.info.descriptor;
-   else
-     desc2 = NULL_TREE;
-   size2 = gfc_index_one_node;
-   for (n = 0; n < expr2->rank; n++)
-     {
-       tmp = fold_build2_loc (input_location, MINUS_EXPR,
- 			     gfc_array_index_type,
- 			     loop->to[n], loop->from[n]);
-       tmp = fold_build2_loc (input_location, PLUS_EXPR,
- 			     gfc_array_index_type,
- 			     tmp, gfc_index_one_node);
-       size2 = fold_build2_loc (input_location, MULT_EXPR,
- 			       gfc_array_index_type,
- 			       tmp, size2);
-     }
-   size1 = gfc_evaluate_now (size1, &fblock);
-   size2 = gfc_evaluate_now (size2, &fblock);
-   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- 			  size1, size2);
-   neq_size = gfc_evaluate_now (cond, &fblock);
  
!   /* If the lhs is allocated and the lhs and rhs are equal length, jump
!      past the realloc/malloc.  This allows F95 compliant expressions
!      to escape allocation on assignment.  */
    jump_label1 = gfc_build_label_decl (NULL_TREE);
    jump_label2 = gfc_build_label_decl (NULL_TREE);
  
--- 6877,6887 ----
    desc = lss->data.info.descriptor;
    gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
    array1 = gfc_conv_descriptor_data_get (desc);
  
!   /* 7.4.1.3 "If variable is an allocated allocatable variable, it is
!      deallocated if expr is an array of different shape or any of the
!      corresponding length type parameter values of variable and expr
!      differ."  This assures F95 compatibility.  */
    jump_label1 = gfc_build_label_decl (NULL_TREE);
    jump_label2 = gfc_build_label_decl (NULL_TREE);
  
*************** gfc_alloc_allocatable_for_assignment (gf
*** 6917,6928 ****
  		  build_empty_stmt (input_location));
    gfc_add_expr_to_block (&fblock, tmp);
  
!   /* Reallocate if sizes are different.  */
!   tmp = build3_v (COND_EXPR, neq_size,
! 		  build1_v (GOTO_EXPR, jump_label1),
! 		  build_empty_stmt (input_location));
!   gfc_add_expr_to_block (&fblock, tmp);
! 
    if (expr2 && expr2->expr_type == EXPR_FUNCTION
  	&& expr2->value.function.isym
  	&& expr2->value.function.isym->conversion)
--- 6893,6899 ----
  		  build_empty_stmt (input_location));
    gfc_add_expr_to_block (&fblock, tmp);
  
!   /* Get arrayspec if expr is a full array.  */
    if (expr2 && expr2->expr_type == EXPR_FUNCTION
  	&& expr2->value.function.isym
  	&& expr2->value.function.isym->conversion)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 6936,6986 ****
    else
      as = NULL;
  
!   /* Reset the lhs bounds if any are different from the rhs.  */ 
!   if (as && expr2->expr_type == EXPR_VARIABLE)
      {
!       for (n = 0; n < expr1->rank; n++)
! 	{
! 	  /* First check the lbounds.  */
! 	  dim = rss->data.info.dim[n];
! 	  lbd = get_std_lbound (expr2, desc2, dim,
! 				as->type == AS_ASSUMED_SIZE);
! 	  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
! 	  cond = fold_build2_loc (input_location, NE_EXPR,
! 				  boolean_type_node, lbd, lbound);
! 	  tmp = build3_v (COND_EXPR, cond,
! 			  build1_v (GOTO_EXPR, jump_label1),
! 			  build_empty_stmt (input_location));
! 	  gfc_add_expr_to_block (&fblock, tmp);
! 
! 	  /* Now check the shape.  */
! 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 				 gfc_array_index_type,
! 				 loop->to[n], loop->from[n]);
! 	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
! 				 gfc_array_index_type,
! 				 tmp, lbound);
! 	  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
! 	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 				 gfc_array_index_type,
! 				 tmp, ubound);
! 	  cond = fold_build2_loc (input_location, NE_EXPR,
! 				  boolean_type_node,
! 				  tmp, gfc_index_zero_node);
! 	  tmp = build3_v (COND_EXPR, cond,
! 			  build1_v (GOTO_EXPR, jump_label1),
! 			  build_empty_stmt (input_location));
! 	  gfc_add_expr_to_block (&fblock, tmp);	  
! 	}
      }
  
!     /* Otherwise jump past the (re)alloc code.  */
!     tmp = build1_v (GOTO_EXPR, jump_label2);
!     gfc_add_expr_to_block (&fblock, tmp);
      
!     /* Add the label to start automatic (re)allocation.  */
!     tmp = build1_v (LABEL_EXPR, jump_label1);
!     gfc_add_expr_to_block (&fblock, tmp);
  
    /* Now modify the lhs descriptor and the associated scalarizer
       variables.
--- 6907,6973 ----
    else
      as = NULL;
  
!   /* If the lhs shape is not the same as the rhs jump to setting the
!      bounds and doing the reallocation.......  */ 
!   for (n = 0; n < expr1->rank; n++)
      {
!       /* Check the shape.  */
!       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
!       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     loop->to[n], loop->from[n]);
!       tmp = fold_build2_loc (input_location, PLUS_EXPR,
! 			     gfc_array_index_type,
! 			     tmp, lbound);
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     tmp, ubound);
!       cond = fold_build2_loc (input_location, NE_EXPR,
! 			      boolean_type_node,
! 			      tmp, gfc_index_zero_node);
!       tmp = build3_v (COND_EXPR, cond,
! 		      build1_v (GOTO_EXPR, jump_label1),
! 		      build_empty_stmt (input_location));
!       gfc_add_expr_to_block (&fblock, tmp);	  
      }
  
!   /* ....else jump past the (re)alloc code.  */
!   tmp = build1_v (GOTO_EXPR, jump_label2);
!   gfc_add_expr_to_block (&fblock, tmp);
      
!   /* Add the label to start automatic (re)allocation.  */
!   tmp = build1_v (LABEL_EXPR, jump_label1);
!   gfc_add_expr_to_block (&fblock, tmp);
! 
!   size1 = gfc_conv_descriptor_size (desc, expr1->rank);
! 
!   /* Get the rhs size.  Fix both sizes.  */
!   if (expr2)
!     desc2 = rss->data.info.descriptor;
!   else
!     desc2 = NULL_TREE;
!   size2 = gfc_index_one_node;
!   for (n = 0; n < expr2->rank; n++)
!     {
!       tmp = fold_build2_loc (input_location, MINUS_EXPR,
! 			     gfc_array_index_type,
! 			     loop->to[n], loop->from[n]);
!       tmp = fold_build2_loc (input_location, PLUS_EXPR,
! 			     gfc_array_index_type,
! 			     tmp, gfc_index_one_node);
!       size2 = fold_build2_loc (input_location, MULT_EXPR,
! 			       gfc_array_index_type,
! 			       tmp, size2);
!     }
! 
!   size1 = gfc_evaluate_now (size1, &fblock);
!   size2 = gfc_evaluate_now (size2, &fblock);
! 
!   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
! 			  size1, size2);
!   neq_size = gfc_evaluate_now (cond, &fblock);
! 
  
    /* Now modify the lhs descriptor and the associated scalarizer
       variables.
*************** gfc_alloc_allocatable_for_assignment (gf
*** 6988,6994 ****
       variable, then it is allocated with each deferred type parameter
       equal to the corresponding type parameters of expr , with the
       shape of expr , and with each lower bound equal to the
!      corresponding element of LBOUND(expr).  */
    size1 = gfc_index_one_node;
    offset = gfc_index_zero_node;
  
--- 6975,6983 ----
       variable, then it is allocated with each deferred type parameter
       equal to the corresponding type parameters of expr , with the
       shape of expr , and with each lower bound equal to the
!      corresponding element of LBOUND(expr).  
!      Reuse size1 to keep a dimension-by-dimension track of the
!      stride of the new array.  */
    size1 = gfc_index_one_node;
    offset = gfc_index_zero_node;
  
Index: gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03
===================================================================
*** gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(revision 168599)
--- gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03	(working copy)
***************
*** 3,8 ****
--- 3,9 ----
  ! reallocation of allocatable arrays on assignment.  The tests
  ! below were generated in the final stages of the development of
  ! this patch.
+ ! test1 has been corrected for PR47051
  !
  ! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
  !            and Tobias Burnus <burnus@gcc.gnu.org>
*************** contains
*** 28,41 ****
      if (lbound (c, 1) .ne. lbound(a, 1)) call abort
      if (ubound (c, 1) .ne. ubound(a, 1)) call abort
      c=b
!     if (lbound (c, 1) .ne. lbound(b, 1)) call abort
!     if (ubound (c, 1) .ne. ubound(b, 1)) call abort
      d=b
      if (lbound (d, 1) .ne. lbound(b, 1)) call abort
      if (ubound (d, 1) .ne. ubound(b, 1)) call abort
      d=a
!     if (lbound (d, 1) .ne. lbound(a, 1)) call abort
!     if (ubound (d, 1) .ne. ubound(a, 1)) call abort
    end subroutine
    subroutine test2
  !
--- 29,49 ----
      if (lbound (c, 1) .ne. lbound(a, 1)) call abort
      if (ubound (c, 1) .ne. ubound(a, 1)) call abort
      c=b
! ! 7.4.1.3 "If variable is an allocated allocatable variable, it is
! ! deallocated if expr is an array of different shape or any of the
! ! corresponding length type parameter values of variable and expr
! ! differ." Here the shape is the same so the deallocation does not
! ! occur and the bounds are not recalculated. This was corrected
! ! for the fix of PR47051. 
!     if (lbound (c, 1) .ne. lbound(a, 1)) call abort
!     if (ubound (c, 1) .ne. ubound(a, 1)) call abort
      d=b
      if (lbound (d, 1) .ne. lbound(b, 1)) call abort
      if (ubound (d, 1) .ne. ubound(b, 1)) call abort
      d=a
! ! The other PR47051 correction.
!     if (lbound (d, 1) .ne. lbound(b, 1)) call abort
!     if (ubound (d, 1) .ne. ubound(b, 1)) call abort
    end subroutine
    subroutine test2
  !