This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR86328 - [8/9 Regression] Runtime segfault reading an allocatable class(*) object in allocate statements
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Wed, 29 Aug 2018 16:55:27 +0100
- Subject: [Patch, fortran] PR86328 - [8/9 Regression] Runtime segfault reading an allocatable class(*) object in allocate statements
The attached patch fixes PR86328 and PR86760. The regression was
caused by my commit r252949.
The parts of the patch that fix the PRs are in trans.c and
trans-array.c. The problem was caused by fixing the expressions that
would provide the 'span' in gfc_build_array_ref, since the latter
expected a variable expression. A number of evaluations of component
array elements were producing pre blocks that were not added and so
the temporaries were not being evaluated.
The fix is to pass the COMPONENT_REF and extract the 'span' directly from it.
The rest of the patch arises from PR86328 comment #12. In fact, this
took most of the time that I have spent on these PRs :-( Having done
this, I felt that I had to include this part of the patch in the
submission. However, I have found a host of related bugs, which I will
put together in one PR.
My inclination is to commit the patch without the parts in resolve.c,
trans-expr.c and pr86328_12.f90, especially for 8-branch. I am open to
suggestions for 9-branch.
Bootstraps and regtests on FC28/x68_64 - OK for 8- and 9-branches?
Paul
2018-08-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/86328
PR fortran/86760
* resolve.c (resolve_ordinary_assign): Ensure that the vtable
is generated for intrinsic assignment to unlimited polymorphic
entities.
* trans-array.c (gfc_conv_scalarized_array_ref): Do not fix
info->descriptor but pass it directly to gfc_build_array_ref.
(gfc_conv_array_ref): Likewise for se->expr.
* trans-expr.c (trans_class_assignment): For unlimited
polymorphic assignments, 'size' must be multiplied by the rhs
'_len' values if non-zero.
(gfc_trans_assignment_1): For scalar polymorphic assignments to
allocatable lhs, finalize and deallocate before the assignment
is made.
* trans.c (gfc_build_array_ref): If 'decl' is a COMPONENT_REF
obtain the span field directly from it.
2018-08-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/86328
PR fortran/86760
* gfortran.dg/pr86328.f90 : New test.
* gfortran.dg/pr86328_12.f90 : New test of the problem reported
in comment 12 of the PR.
* gfortran.dg/pr86760.f90 : New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 263915)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 10258,10263 ****
--- 10258,10271 ----
gfc_ref *ref;
symbol_attribute attr;
+ /* Make sure that a vtable exists for intrinsic rhs of an assignment
+ to an unlimited polymorphic lhs. */
+ if (code->expr1
+ && code->expr1->ts.type == BT_CLASS
+ && code->expr1->ts.u.derived
+ && UNLIMITED_POLY (code->expr1))
+ gfc_find_vtab (&code->expr2->ts);
+
if (gfc_extend_assign (code, ns))
{
gfc_expr** rhsptr;
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 263915)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_conv_scalarized_array_ref (gfc_se *
*** 3414,3424 ****
if (is_pointer_array (info->descriptor))
{
if (TREE_CODE (info->descriptor) == COMPONENT_REF)
! {
! decl = gfc_evaluate_now (info->descriptor, &se->pre);
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
! TREE_USED (decl) = 1;
! }
else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
decl = TREE_OPERAND (info->descriptor, 0);
--- 3414,3420 ----
if (is_pointer_array (info->descriptor))
{
if (TREE_CODE (info->descriptor) == COMPONENT_REF)
! decl = info->descriptor;
else if (TREE_CODE (info->descriptor) == INDIRECT_REF)
decl = TREE_OPERAND (info->descriptor, 0);
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
*** 3659,3669 ****
&& is_pointer_array (se->expr))
{
if (TREE_CODE (se->expr) == COMPONENT_REF)
! {
! decl = gfc_evaluate_now (se->expr, &se->pre);
! GFC_DECL_PTR_ARRAY_P (decl) = 1;
! TREE_USED (decl) = 1;
! }
else if (TREE_CODE (se->expr) == INDIRECT_REF)
decl = TREE_OPERAND (se->expr, 0);
else
--- 3655,3661 ----
&& is_pointer_array (se->expr))
{
if (TREE_CODE (se->expr) == COMPONENT_REF)
! decl = se->expr;
else if (TREE_CODE (se->expr) == INDIRECT_REF)
decl = TREE_OPERAND (se->expr, 0);
else
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 263916)
--- gcc/fortran/trans-expr.c (working copy)
*************** trans_class_assignment (stmtblock_t *blo
*** 9922,9933 ****
{
stmtblock_t alloc;
tree class_han;
- tmp = gfc_vptr_size_get (vptr);
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
gfc_init_block (&alloc);
! gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
--- 9922,9948 ----
{
stmtblock_t alloc;
tree class_han;
+ tree size;
+ tree ctmp;
+
+ size = gfc_vptr_size_get (vptr);
+ if (UNLIMITED_POLY (lhs))
+ {
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_class_len_get (TREE_OPERAND (vptr, 0)));
+ ctmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (TREE_TYPE (tmp)));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, tmp, ctmp, size);
+ }
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
gfc_init_block (&alloc);
! gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10306,10315 ****
tmp = NULL_TREE;
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)
--- 10321,10351 ----
tmp = NULL_TREE;
if (is_poly_assign)
! {
! if (lhs_attr.allocatable && dealloc && lss == gfc_ss_terminator)
! {
! tree ptr;
!
! ptr = lse.expr;
! if (GFC_CLASS_TYPE_P (TREE_TYPE (ptr)))
! ptr = gfc_class_data_get (ptr);
!
! /* This provides finalization of the lhs before the assignment. */
! tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE,
! NULL_TREE, true,
! expr1, expr1->ts);
! gfc_add_expr_to_block (&block, tmp);
! tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! void_type_node, ptr,
! build_int_cst (TREE_TYPE (ptr), 0));
! gfc_add_expr_to_block (&block, tmp);
! }
!
! 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)
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 263915)
--- gcc/fortran/trans.c (working copy)
*************** gfc_build_array_ref (tree base, tree off
*** 407,413 ****
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! span = get_array_span (type, decl);
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
--- 407,418 ----
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
! {
! if (TREE_CODE (decl) == COMPONENT_REF)
! span = gfc_conv_descriptor_span_get (decl);
! else
! span = get_array_span (type, decl);
! }
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
Index: gcc/testsuite/gfortran.dg/pr86328.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86328.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86328.f90 (working copy)
***************
*** 0 ****
--- 1,49 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Martin <mscfd@gmx.net>
+ !
+ program ptr_alloc
+
+ type :: t
+ class(*), allocatable :: val
+ end type
+
+ type :: list
+ type(t), dimension(:), pointer :: ll
+ end type
+
+ integer :: i
+ type(list) :: a
+
+ allocate(a%ll(1:2))
+ do i = 1,2
+ allocate(a%ll(i)%val, source=i)
+ end do
+
+ do i = 1,2
+ call rrr(a, i)
+ end do
+
+ do i = 1,2
+ deallocate(a%ll(i)%val)
+ end do
+ deallocate (a%ll)
+ contains
+
+ subroutine rrr(a, i)
+ type(list), intent(in) :: a
+ class(*), allocatable :: c
+ integer :: i
+
+ allocate(c, source=a%ll(i)%val)
+ select type (c)
+ type is (integer)
+ if (c .ne. i) stop 1
+ end select
+
+ end subroutine
+
+ end
Index: gcc/testsuite/gfortran.dg/pr86328_12.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86328_12.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86328_12.f90 (working copy)
***************
*** 0 ****
--- 1,61 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86328 comment 12. This had nothing to do with
+ ! the original PR. See below.
+ !
+ ! Contributed by Martin <mscfd@gmx.net>
+ !
+ program classstar_alloc3
+
+ type :: t
+ class(*), allocatable :: val
+ end type
+
+ type :: list
+ type(t), dimension(:), pointer :: ll
+ end type
+
+ integer :: i
+ type(list) :: a
+
+ allocate(a%ll(1:2))
+ do i = 1,2
+ allocate(a%ll(i)%val, source='01')
+ end do
+
+ call rrr(a)
+
+ do i = 1,2
+ deallocate(a%ll(i)%val)
+ end do
+
+ deallocate(a%ll)
+
+ contains
+
+ subroutine rrr(a)
+ type(list), intent(in) :: a
+ class(*), allocatable :: c
+
+ allocate(c, source=a%ll(2)%val)
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 2) stop 1
+ if (c .ne. '01') stop 2
+ end select
+
+ c = a%ll(2)%val ! This caused invalid reads.
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 2) stop 3
+ if (c .ne. '01') stop 4
+ end select
+
+ c = '123456' ! 'c' remained size 2.
+ select type (c)
+ type is (character(len=*))
+ if (len (c) .ne. 6) stop 5
+ if (c .ne. '123456') stop 6
+ end select
+ end subroutine
+ end program classstar_alloc3
Index: gcc/testsuite/gfortran.dg/pr86760.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pr86760.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/pr86760.f90 (working copy)
***************
*** 0 ****
--- 1,57 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR86760 in which temporaries were not being
+ ! assigned for array component references.
+ !
+ ! Contributed by Chris Hansen <hansec@uw.edu>
+ !
+ MODULE test_nesting_mod
+ IMPLICIT NONE
+ TYPE :: test_obj1
+ CONTAINS
+ PROCEDURE :: destroy
+ END TYPE
+
+ TYPE :: obj_ptr
+ CLASS(test_obj1), POINTER :: f => NULL()
+ END TYPE
+
+ TYPE :: obj_container
+ TYPE(obj_ptr), POINTER, DIMENSION(:) :: v => NULL()
+ END TYPE
+
+ integer :: ctr = 0
+
+ CONTAINS
+
+ SUBROUTINE destroy(self)
+ CLASS(test_obj1), INTENT(INOUT):: self
+ ctr = ctr + 1
+ END SUBROUTINE
+
+ SUBROUTINE container_destroy(self)
+ type(obj_container), INTENT(INOUT) :: self
+ INTEGER :: i
+ DO i=1,ubound(self%v,1)
+ CALL self%v(i)%f%destroy()
+ END DO
+ END SUBROUTINE
+
+ END MODULE
+
+
+ PROGRAM test_nesting_ptr
+ USE test_nesting_mod
+ IMPLICIT NONE
+ INTEGER :: i
+ INTEGER, PARAMETER :: n = 2
+ TYPE(obj_container) :: var
+
+ ALLOCATE(var%v(n))
+ DO i=1,n
+ ALLOCATE(test_obj1::var%v(i)%f)
+ END DO
+ CALL container_destroy(var)
+
+ if (ctr .ne. 2) stop 1
+ END