diff mbox series

[fortran] PR83118 - [8/9/10 Regression] Bad intrinsic assignment of class(*) array component of derived type

Message ID CAGkQGi+foX8rJbDckkSPVimXcDxfZWND+tWfakD+K8RhMkJjGQ@mail.gmail.com
State New
Headers show
Series [fortran] PR83118 - [8/9/10 Regression] Bad intrinsic assignment of class(*) array component of derived type | expand

Commit Message

Paul Richard Thomas Nov. 17, 2019, 6:34 p.m. UTC 
This is a somewhat delayed patch to fix issues with the original
patch, as flagged up by Rainer in comment #12, Rainer in comment #14
and Eric in comment #15. The fix for these problems was posted in
April in comment #17. It was thoroughly tested but remained
uncommitted because my attention was elsewhere.

I have added the fix to Damian's failing test posted at
https://gcc.gnu.org/ml/fortran/2019-11/msg00061.html ? and referenced
by Tobias in comment #23.

The submitted testcase leaks memory as in PR38319, which I will return
to as I work my way through my assigned PRs. I have returned to this
latter PR on several occasions and have thus far not managed to find a
fix for the problem, which is primarily due to various issues with
allocatable component derived type constructor.

For the main part, the patch relies on ensuring vtables are available
and forcing all assignments to unlimited polymorphic entities to use
the vtable _copy.

Regtests on FC30/x86_64 - OK to commit?

Paul

2019-11-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/83118
    * resolve.c (resolve_ordinary_assign): Generate a vtable if
    necessary for scalar non-polymorphic rhs's to unlimited lhs's.
    * trans-array.c (structure_alloc_comps): Delete trailing white
    spaces.
    (gfc_alloc_allocatable_for_assignment): Use earlier evaluation
    of 'cond_null'. If unlimited poly initialize 'size1' to zero
    and jump to 'no_shape_tests'. Force reallocation of unlimited
    polymorphic lhs's. For allocation to unlimited polymorphic lhs
    from a class rhs, use the vtable size.
    * trans-expr.c (gfc_conv_procedure_call): Ensure the vtable is
    present for passing a non-class actual to an unlimited formal.
    (gfc_trans_assignment_1): Simplify some of the logic with
    'realloc_flag'.
    (realloc_flag): Set 'vptr_copy' for all array assignments to
    unlimited polymorphic lhs.

2019-11-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/83118
    * gfortran.dg/unlimited_polymorphic_31.f03: New test.

Comments

Tobias Burnus Nov. 18, 2019, 10:24 a.m. UTC | #1 
On 11/17/19 7:34 PM, Paul Richard Thomas wrote:
[…]
Sorry for not yet reviewing the code, but the following caught my eye:
>      (gfc_alloc_allocatable_for_assignment): […]
>      Force reallocation of unlimited
>      polymorphic lhs's. […]
> […]
> !   /* If the lhs is deferred length or unlimited polymorphic, assume that
> !      the element size changes and force a reallocation.  */
> !   if (expr1->ts.deferred || UNLIMITED_POLY (expr1))
I wonder whether this assumption breaks code, which relies on a pointer 
address not changing, cf. test case below.

I think the standard does not state explicitly that no reallocation 
happens, but I think it can be deduced. In any case, the reallocation is 
only supposed to happen for (F2018, 10.2.1.3p1):
"If the variable is an allocated allocatable variable, it is deallocated 
ifexpr is an array of different shape, any corresponding length type 
parameter values of the variable andexprdiffer, or the variable is 
polymorphic and the dynamic type or any corresponding kind type 
parameter values of the variable andexpr differ."

Cheers,

Tobias

implicit none (type, external)
integer, pointer :: ptr
class(*), target, allocatable :: alloc
allocate(integer :: alloc)
select type(alloc)
   type is(integer)
     alloc = 67
     ptr => alloc
end select
call assign(alloc)
!print *, ptr
if (ptr /= 5) error stop 1
select type(alloc)
   type is(integer)
    !print *, alloc
    if (ptr /= 5) error stop 2
end select
contains
subroutine assign(x)
   class(*), allocatable :: x
   x = 5
end subroutine assign
end
Paul Richard Thomas Nov. 18, 2019, 7:05 p.m. UTC | #2 
Hi Tobias,

I notice that your scalar allocation does not use reallocation at all.
There is something not quite right there.

However, this just demonstrates one of the gotchas associated with
pointers, especially where the target is allocatable, and has nothing
to do with reallocation on assignment. Try this case, which does not
use class assignment.

implicit none (type, external)
integer, pointer :: ptr(:)
class(*), target, allocatable :: alloc(:)
allocate(integer :: alloc(1))
select type(alloc)
   type is(integer)
     alloc = 67
     ptr => alloc
end select
call assign(alloc)
!print *, ptr  ! This causes an invalid read of size 4
!if (ptr(1) /= 5) error stop 1
select type(alloc)
   type is(integer)
    print *, alloc
    if (associated (ptr, alloc)) then
      print *, ptr
    else
      print *, "ptr is no longer associated with assoc"
    end if
    !if (ptr(1) /= 5) error stop 2
end select
deallocate(alloc)
contains
subroutine assign(x)
   class(*), allocatable :: x(:)
   if (allocated(x)) deallocate(x)
   allocate (x, source = [5])
end subroutine assign
end

[pault@pc30 pr83118]$  ./a.out
           5
           5

Interestingly, under valgrind the result is:
           5
 ptr is no longer associated with assoc

Cheers

Paul


On Mon, 18 Nov 2019 at 10:24, Tobias Burnus <tobias@codesourcery.com> wrote:
>
> On 11/17/19 7:34 PM, Paul Richard Thomas wrote:
> […]
> Sorry for not yet reviewing the code, but the following caught my eye:
> >      (gfc_alloc_allocatable_for_assignment): […]
> >      Force reallocation of unlimited
> >      polymorphic lhs's. […]
> > […]
> > !   /* If the lhs is deferred length or unlimited polymorphic, assume that
> > !      the element size changes and force a reallocation.  */
> > !   if (expr1->ts.deferred || UNLIMITED_POLY (expr1))
> I wonder whether this assumption breaks code, which relies on a pointer
> address not changing, cf. test case below.
>
> I think the standard does not state explicitly that no reallocation
> happens, but I think it can be deduced. In any case, the reallocation is
> only supposed to happen for (F2018, 10.2.1.3p1):
> "If the variable is an allocated allocatable variable, it is deallocated
> ifexpr is an array of different shape, any corresponding length type
> parameter values of the variable andexprdiffer, or the variable is
> polymorphic and the dynamic type or any corresponding kind type
> parameter values of the variable andexpr differ."
>
> Cheers,
>
> Tobias
>
> implicit none (type, external)
> integer, pointer :: ptr
> class(*), target, allocatable :: alloc
> allocate(integer :: alloc)
> select type(alloc)
>    type is(integer)
>      alloc = 67
>      ptr => alloc
> end select
> call assign(alloc)
> !print *, ptr
> if (ptr /= 5) error stop 1
> select type(alloc)
>    type is(integer)
>     !print *, alloc
>     if (ptr /= 5) error stop 2
> end select
> contains
> subroutine assign(x)
>    class(*), allocatable :: x
>    x = 5
> end subroutine assign
> end
>
diff mbox series

Patch

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 278354)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 10868,10874 ****
  
    /* Make sure there is a vtable and, in particular, a _copy for the
       rhs type.  */
!   if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
      gfc_find_vtab (&rhs->ts);
  
    bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
--- 10868,10874 ----
  
    /* Make sure there is a vtable and, in particular, a _copy for the
       rhs type.  */
!   if (UNLIMITED_POLY (lhs) && rhs->ts.type != BT_CLASS)
      gfc_find_vtab (&rhs->ts);
  
    bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 278354)
--- gcc/fortran/trans-array.c	(working copy)
*************** structure_alloc_comps (gfc_symbol * der_
*** 8822,8828 ****
  
  	  cdesc = gfc_create_var (cdesc, "cdesc");
  	  DECL_ARTIFICIAL (cdesc) = 1;
!   
  	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
  	  		  gfc_get_dtype_rank_type (1, tmp));
  	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
--- 8822,8828 ----
  
  	  cdesc = gfc_create_var (cdesc, "cdesc");
  	  DECL_ARTIFICIAL (cdesc) = 1;
! 
  	  gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
  	  		  gfc_get_dtype_rank_type (1, tmp));
  	  gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
*************** structure_alloc_comps (gfc_symbol * der_
*** 8833,8839 ****
  					  gfc_index_one_node);
  	  gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
  					  gfc_index_zero_node, ubound);
!   
  	  if (attr->dimension)
  	    comp = gfc_conv_descriptor_data_get (comp);
  	  else
--- 8833,8839 ----
  					  gfc_index_one_node);
  	  gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
  					  gfc_index_zero_node, ubound);
! 
  	  if (attr->dimension)
  	    comp = gfc_conv_descriptor_data_get (comp);
  	  else
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10184,10198 ****
  			     rss->info->string_length);
        cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
  				   logical_type_node, tmp, cond_null);
      }
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);
  
-   tmp = build3_v (COND_EXPR, cond_null,
- 		  build1_v (GOTO_EXPR, jump_label1),
- 		  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
--- 10184,10194 ----
  			     rss->info->string_length);
        cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
  				   logical_type_node, tmp, cond_null);
+       cond_null= gfc_evaluate_now (cond_null, &fblock);
      }
    else
      cond_null= gfc_evaluate_now (cond_null, &fblock);
  
    /* Get arrayspec if expr is a full array.  */
    if (expr2 && expr2->expr_type == EXPR_FUNCTION
  	&& expr2->value.function.isym
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10207,10212 ****
--- 10203,10220 ----
    else
      as = NULL;
  
+   if (UNLIMITED_POLY (expr1))
+     {
+       size1 = gfc_create_var (gfc_array_index_type, NULL);
+       gfc_add_modify (&fblock, size1, gfc_index_zero_node);
+       goto no_shape_tests;
+     }
+ 
+   tmp = build3_v (COND_EXPR, cond_null,
+ 		  build1_v (GOTO_EXPR, jump_label1),
+ 		  build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&fblock, tmp);
+ 
    /* 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++)
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10253,10258 ****
--- 10261,10268 ----
  		  gfc_finish_block (&realloc_block));
    gfc_add_expr_to_block (&fblock, tmp);
  
+ no_shape_tests:
+ 
    /* Get the rhs size and fix it.  */
    if (expr2)
      desc2 = rss->info->data.array.descriptor;
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10277,10285 ****
    cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
  			  size1, size2);
  
!   /* If the lhs is deferred length, assume that the element size
!      changes and force a reallocation.  */
!   if (expr1->ts.deferred)
      neq_size = gfc_evaluate_now (logical_true_node, &fblock);
    else
      neq_size = gfc_evaluate_now (cond, &fblock);
--- 10287,10295 ----
    cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
  			  size1, size2);
  
!   /* If the lhs is deferred length or unlimited polymorphic, assume that
!      the element size changes and force a reallocation.  */
!   if (expr1->ts.deferred || UNLIMITED_POLY (expr1))
      neq_size = gfc_evaluate_now (logical_true_node, &fblock);
    else
      neq_size = gfc_evaluate_now (cond, &fblock);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10424,10431 ****
  			     gfc_array_index_type, tmp,
  			     expr1->ts.u.cl->backend_decl);
      }
!   else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
!     tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
    else
      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
    tmp = fold_convert (gfc_array_index_type, tmp);
--- 10434,10444 ----
  			     gfc_array_index_type, tmp,
  			     expr1->ts.u.cl->backend_decl);
      }
!   else if (UNLIMITED_POLY (expr1))
!     if (expr2->ts.type != BT_CLASS)
!       tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
!     else
!       tmp = gfc_class_vtab_size_get (TREE_OPERAND (desc2, 0));
    else
      tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
    tmp = fold_convert (gfc_array_index_type, tmp);
*************** gfc_alloc_allocatable_for_assignment (gf
*** 10603,10613 ****
    alloc_expr = gfc_finish_block (&alloc_block);
  
    /* Malloc if not allocated; realloc otherwise.  */
!   tmp = build_int_cst (TREE_TYPE (array1), 0);
!   cond = fold_build2_loc (input_location, EQ_EXPR,
! 			  logical_type_node,
! 			  array1, tmp);
!   tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
    gfc_add_expr_to_block (&fblock, tmp);
  
    /* Make sure that the scalarizer data pointer is updated.  */
--- 10616,10622 ----
    alloc_expr = gfc_finish_block (&alloc_block);
  
    /* Malloc if not allocated; realloc otherwise.  */
!   tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
    gfc_add_expr_to_block (&fblock, tmp);
  
    /* Make sure that the scalarizer data pointer is updated.  */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 278354)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5586,5593 ****
--- 5586,5595 ----
  	{
  	  /* The intrinsic type needs to be converted to a temporary
  	     CLASS object for the unlimited polymorphic formal.  */
+ 	  gfc_find_vtab (&e->ts);
  	  gfc_init_se (&parmse, se);
  	  gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+ 
  	}
        else if (se->ss && se->ss->info->useflags)
  	{
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10717,10722 ****
--- 10719,10725 ----
    bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
    symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
    bool is_poly_assign;
+   bool realloc_flag;
  
    /* Assignment of the form lhs = rhs.  */
    gfc_start_block (&block);
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10757,10762 ****
--- 10760,10769 ----
  		       || gfc_is_class_array_ref (expr2, NULL)
  		       || gfc_is_class_scalar_expr (expr2));
  
+   realloc_flag = flag_realloc_lhs
+ 		 && gfc_is_reallocatable_lhs (expr1)
+ 		 && expr2->rank
+ 		 && !is_runtime_conformable (expr1, expr2);
  
    /* Only analyze the expressions for coarray properties, when in coarray-lib
       mode.  */
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 11001,11008 ****
    if (is_poly_assign)
      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)
--- 11008,11016 ----
    if (is_poly_assign)
      tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
  				  use_vptr_copy || (lhs_attr.allocatable
! 						     && !lhs_attr.dimension),
! 				  !realloc_flag && 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)
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 11107,11116 ****
  	}
  
        /* F2003: Allocate or reallocate lhs of allocatable array.  */
!       if (flag_realloc_lhs
! 	  && gfc_is_reallocatable_lhs (expr1)
! 	  && expr2->rank
! 	  && !is_runtime_conformable (expr1, expr2))
  	{
  	  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
  	  ompws_flags &= ~OMPWS_SCALARIZER_WS;
--- 11115,11121 ----
  	}
  
        /* F2003: Allocate or reallocate lhs of allocatable array.  */
!       if (realloc_flag)
  	{
  	  realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
  	  ompws_flags &= ~OMPWS_SCALARIZER_WS;
*************** gfc_trans_assignment (gfc_expr * expr1,
*** 11219,11226 ****
  	return tmp;
      }
  
!   if (UNLIMITED_POLY (expr1) && expr1->rank
!       && expr2->ts.type != BT_CLASS)
      use_vptr_copy = true;
  
    /* Fallback to the scalarizer to generate explicit loops.  */
--- 11224,11230 ----
  	return tmp;
      }
  
!   if (UNLIMITED_POLY (expr1) && expr1->rank)
      use_vptr_copy = true;
  
    /* Fallback to the scalarizer to generate explicit loops.  */
Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03
===================================================================
*** gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03	(nonexistent)
--- gcc/testsuite/gfortran.dg/unlimited_polymorphic_31.f03	(working copy)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ !
+ ! Test the fix of the test case referenced in comment 17 of PR83118.
+ !
+ ! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
+ !
+   implicit none
+   type Wrapper
+     class(*), allocatable :: elements(:)
+   end type
+   type Mytype
+     real(4) :: r = 42.0
+   end type
+ 
+   call driver
+ contains
+   subroutine driver
+     class(*), allocatable :: obj
+     type(Wrapper) w
+     integer(4) :: expected4(2) = [42_4, 43_4]
+     integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
+ 
+     w = new_wrapper (expected4)
+     obj = w
+     call test (obj, 0)
+     obj =  new_wrapper (expected8) ! Used to generate a linker error
+     call test (obj, 10)
+     obj = new_wrapper ([mytype (99.0)])
+     call test (obj, 100)
+     obj = Mytype (42.0) ! Used to generate a linker error
+     call test (obj, 1000)
+   end subroutine
+   function new_wrapper(array) result (res)
+     class(*) :: array(:)
+     type(Wrapper) :: res
+     res%elements = array ! Used to runtime segfault
+   end function
+   subroutine test (arg, idx)
+     class(*) :: arg
+     integer :: idx
+     select type (arg)
+       type is (wrapper)
+         select type (z => arg%elements)
+           type is (integer(4))
+             if (any (z .ne. [42_4, 43_4])) stop 1 + idx
+           type is (integer(8))
+             if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
+           type is (Mytype)
+             if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
+         class default
+           stop 2 + idx
+         end select
+       type is (Mytype)
+         if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
+       class default
+         stop 3 + idx
+     end select
+   end subroutine
+ end