Hi All,
This patch is very straightforward. The PR itself was fixed by not
freeing the parameterized components on leaving function scope. The
lhs expression in the assignment had pointers to parameterized
components that were overwritten on assignment, thereby causing some
memory leakage. This is fixed in trans-expr.c by deallocating them
before assignment.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk? I will
commit in 24 hours if I receive no contrary comments.
Paul
2017-12-27 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/83567
* trans-expr.c (gfc_trans_assignment_1): Free parameterized
components of the lhs if dealloc is set.
*trans-decl.c (gfc_trans_deferred_vars): Do not free the
parameterized components of function results on leaving scope.
2017-12-27 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/83567
* gfortran.dg/pdt_26.f90 : New test.
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 256000)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_trans_assignment_1 (gfc_expr * expr1
*** 10076,10081 ****
--- 10076,10103 ----
gfc_trans_runtime_check (true, false, cond, &loop.pre,
&expr1->where, msg);
}
+
+ /* Deallocate the lhs parameterized components if required. */
+ if (dealloc)
+ {
+ if (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived
+ && expr1->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, lse.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&lse.pre, tmp);
+ }
+ else if (expr1->ts.type == BT_CLASS
+ && CLASS_DATA (expr1)->ts.u.derived
+ && CLASS_DATA (expr1)->ts.u.derived->attr.pdt_type)
+ {
+ tmp = gfc_class_data_get (lse.expr);
+ tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr1)->ts.u.derived,
+ tmp, expr1->rank);
+ gfc_add_expr_to_block (&lse.pre, tmp);
+ }
+ }
}
/* Assignments of scalar derived types with allocatable components
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 256000)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4344,4352 ****
sym->as ? sym->as->rank : 0,
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
! tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
! sym->backend_decl,
! sym->as ? sym->as->rank : 0);
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
}
else if (sym->attr.dummy)
--- 4344,4355 ----
sym->as ? sym->as->rank : 0,
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
! if (!sym->attr.result)
! tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
! sym->backend_decl,
! sym->as ? sym->as->rank : 0);
! else
! tmp = NULL_TREE;
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
}
else if (sym->attr.dummy)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4376,4383 ****
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_class_data_get (sym->backend_decl);
! tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
! data->as ? data->as->rank : 0);
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
}
else if (sym->attr.dummy)
--- 4379,4389 ----
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
tmp = gfc_class_data_get (sym->backend_decl);
! if (!sym->attr.result)
! tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp,
! data->as ? data->as->rank : 0);
! else
! tmp = NULL_TREE;
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp);
}
else if (sym->attr.dummy)
Index: gcc/testsuite/gfortran.dg/pdt_26.f03
===================================================================
*** gcc/testsuite/gfortran.dg/pdt_26.f03 (nonexistent)
--- gcc/testsuite/gfortran.dg/pdt_26.f03 (working copy)
***************
*** 0 ****
--- 1,46 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Test the fix for PR83567 in which the parameterized component 'foo' was
+ ! being deallocated before return from 'addw', with consequent segfault in
+ ! the main program.
+ !
+ ! Contributed by Berke Durak <berke.du...@gmail.com>
+ ! The function 'addvv' has been made elemental so that the test can check that
+ ! arrays are correctly treated and that no memory leaks occur.
+ !
+ module pdt_m
+ implicit none
+ type :: vec(k)
+ integer, len :: k=3
+ integer :: foo(k)=[1,2,3]
+ end type vec
+ contains
+ elemental function addvv(a,b) result(c)
+ type(vec(k=*)), intent(in) :: a
+ type(vec(k=*)), intent(in) :: b
+ type(vec(k=a%k)) :: c
+
+ c%foo=a%foo+b%foo
+ end function
+ end module pdt_m
+
+ program test_pdt
+ use pdt_m
+ implicit none
+ type(vec) :: u,v,w, a(2), b(2), c(2)
+ integer :: i
+
+ u%foo=[1,2,3]
+ v%foo=[2,3,4]
+ w=addvv(u,v)
+ if (any (w%foo .ne. [3,5,7])) call abort
+ do i = 1 , a(1)%k
+ a%foo(i) = i + 4
+ b%foo(i) = i + 7
+ end do
+ c = addvv(a,b)
+ if (any (c(1)%foo .ne. [13,15,17])) call abort
+ end program test_pdt
+ ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } }
