* [Patch, Fortran] Finalize nonallocatables with INTENT(out)
@ 2013-05-31 16:39 Tobias Burnus
2013-05-31 20:39 ` Tobias Burnus
2013-06-06 8:35 ` *PING* / " Tobias Burnus
0 siblings, 2 replies; 9+ messages in thread
From: Tobias Burnus @ 2013-05-31 16:39 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 827 bytes --]
This patch adds finalization support for INTENT(out) for nonallocatable
dummy arguments.
Additionally, it addresses a missed optimization: The previous code
tried to deallocate allocatable components even if the dummy argument
was already an allocatable. That's a missed optimization as gfortran
deallocates allocatables in the caller.
OK for the trunk?
Note: This patch depends on
http://gcc.gnu.org/ml/fortran/2013-05/msg00134.html
Tobias
PS: There are many more places where finalization should happen, e.g.
intrinsic assignment (LHS + RHS func/constructor finalization),
end-of-scope of nonallocatables. And some issues related coarrays,
elemental+optional, etc.
However, I stop here for the moment as I run out of time - and writing
on-top patches of not reviewed/committed patches starts to become a chore.
[-- Attachment #2: final-intentout-v2.diff --]
[-- Type: text/x-patch, Size: 5586 bytes --]
2013-05-31 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans-decl.c (init_intent_out_dt): Call finalizer
when approriate.
2013-05-31 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.dg/finalize_10.f90: New.
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 100ec18..7521dee 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3501,38 +3503,56 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = NULL_TREE;
+
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (!f->sym->attr.allocatable
+ && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
+ }
- if (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master)
- {
- present = gfc_conv_expr_present (f->sym);
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- present, tmp,
- build_empty_stmt (input_location));
- }
+ if (tmp == NULL_TREE && !f->sym->attr.allocatable
+ && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+ f->sym->backend_decl,
+ f->sym->as ? f->sym->as->rank : 0);
- gfc_add_expr_to_block (&init, tmp);
+ if (tmp != NULL_TREE && (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master))
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp, build_empty_stmt (input_location));
}
- else if (f->sym->value)
+
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&init, tmp);
+ else if (f->sym->value && !f->sym->attr.allocatable)
gfc_init_default_dt (f->sym, &init, true);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
&& !CLASS_DATA (f->sym)->attr.class_pointer
- && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+ && !CLASS_DATA (f->sym)->attr.allocatable)
{
- tmp = gfc_class_data_get (f->sym->backend_decl);
- if (CLASS_DATA (f->sym)->as == NULL)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
- tmp,
- CLASS_DATA (f->sym)->as ?
- CLASS_DATA (f->sym)->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
{
--- /dev/null 2013-05-31 08:03:29.909107813 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-05-31 16:23:06.377019214 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+! Finalize nonallocatable INTENT(OUT)
+!
+module m
+ type t
+ end type t
+ type t2
+ contains
+ final :: fini
+ end type t2
+contains
+ elemental subroutine fini(var)
+ type(t2), intent(inout) :: var
+ end subroutine fini
+end module m
+
+subroutine foo(x,y,aa,bb)
+ use m
+ class(t), intent(out) :: x(:),y
+ type(t2), intent(out) :: aa(:),bb
+end subroutine foo
+
+! Finalize CLASS + set default init
+! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
+
+! FINALIZE TYPE:
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&parm.\[0-9\]+, 0, 0);" 1 "original" } }
+! { dg!final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&desc.\[0-9\]+, 0, 0);" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index d261973..04ee7f2 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -11,11 +11,12 @@ type :: t
integer, allocatable :: i(:)
end type
+block ! New block as the main program implies SAVE
type(t) :: a
call init(a)
call init(a)
-
+end block
contains
subroutine init(x)
@@ -25,5 +26,6 @@ contains
end program
-! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-05-31 16:39 [Patch, Fortran] Finalize nonallocatables with INTENT(out) Tobias Burnus
@ 2013-05-31 20:39 ` Tobias Burnus
2013-06-06 8:35 ` *PING* / " Tobias Burnus
1 sibling, 0 replies; 9+ messages in thread
From: Tobias Burnus @ 2013-05-31 20:39 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1052 bytes --]
Tobias Burnus wrote:
> This patch adds finalization support for INTENT(out) for
> nonallocatable dummy arguments.
Attached is an additional test case, which checks that the finalization
wrapper handles strides correctly. The stride handling occurs trice:
- For elemental finalization procedures in the scalarizer
- For array finalization procedures, in the check whether it can be
directly dispatched or it has to be packed
- In the packing itself.
(There is currently no test case which checks whether no
copy-in/copy-out is done unless required. But the wrapper shouldn't do a
copy out for INTENT(IN) and only a copy-in(+copy-out) if the elem_size
is different from the type size - or if the array has strides and the
dummy argument is either CONTIGUOUS or nor assumed shape.)
The test case requires the intent(out) patch for nonallocatables,
http://gcc.gnu.org/ml/fortran/2013-05/msg00135.html
Which in turn requires the finalization patch for allocatables,
http://gcc.gnu.org/ml/fortran/2013-05/msg00134.html
OK for the trunk?
Tobias
[-- Attachment #2: finalize_15.f90 --]
[-- Type: text/x-fortran, Size: 5079 bytes --]
! { dg-do run }
!
! PR fortran/37336
!
! Check the scalarizer/array packing with strides
! in the finalization wrapper
!
module m
implicit none
type t1
integer :: i
contains
final :: fini_elem
end type t1
type, extends(t1) :: t1e
integer :: j
contains
final :: fini_elem2
end type t1e
type t2
integer :: i
contains
final :: fini_shape
end type t2
type, extends(t2) :: t2e
integer :: j
contains
final :: fini_shape2
end type t2e
type t3
integer :: i
contains
final :: fini_explicit
end type t3
type, extends(t3) :: t3e
integer :: j
contains
final :: fini_explicit2
end type t3e
integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e
contains
impure elemental subroutine fini_elem(x)
type(t1), intent(inout) :: x
integer :: i, j, i2, j2
if (cnt1e /= 5*4) call abort ()
j = mod (cnt1,5)+1
i = cnt1/5 + 1
i2 = (i-1)*3 + 1
j2 = (j-1)*2 + 1
if (x%i /= j2 + 100*i2) call abort ()
x%i = x%i * (-13)
cnt1 = cnt1 + 1
end subroutine fini_elem
impure elemental subroutine fini_elem2(x)
type(t1e), intent(inout) :: x
integer :: i, j, i2, j2
j = mod (cnt1e,5)+1
i = cnt1e/5 + 1
i2 = (i-1)*3 + 1
j2 = (j-1)*2 + 1
if (x%i /= j2 + 100*i2) call abort ()
if (x%j /= (j2 + 100*i2)*100) call abort ()
x%j = x%j * (-13)
cnt1e = cnt1e + 1
end subroutine fini_elem2
subroutine fini_shape(x)
type(t2) :: x(:,:)
if (cnt2e /= 1 .or. cnt2 /= 0) call abort ()
call check_var_sec(x%i, 1)
x%i = x%i * (-13)
cnt2 = cnt2 + 1
end subroutine fini_shape
subroutine fini_shape2(x)
type(t2e) :: x(:,:)
call check_var_sec(x%i, 1)
call check_var_sec(x%j, 100)
x%j = x%j * (-13)
cnt2e = cnt2e + 1
end subroutine fini_shape2
subroutine fini_explicit(x)
type(t3) :: x(5,4)
if (cnt3e /= 1 .or. cnt3 /= 0) call abort ()
call check_var_sec(x%i, 1)
x%i = x%i * (-13)
cnt3 = cnt3 + 1
end subroutine fini_explicit
subroutine fini_explicit2(x)
type(t3e) :: x(5,4)
call check_var_sec(x%i, 1)
call check_var_sec(x%j, 100)
x%j = x%j * (-13)
cnt3e = cnt3e + 1
end subroutine fini_explicit2
subroutine fin_test_1(x)
class(t1), intent(out) :: x(5,4)
end subroutine fin_test_1
subroutine fin_test_2(x)
class(t2), intent(out) :: x(:,:)
end subroutine fin_test_2
subroutine fin_test_3(x)
class(t3), intent(out) :: x(:,:)
if (any (shape(x) /= [5,4])) call abort ()
end subroutine fin_test_3
subroutine check_var_sec(x, factor)
integer :: x(:,:)
integer, value :: factor
integer :: i, j, i2, j2
do i = 1, 4
i2 = (i-1)*3 + 1
do j = 1, 5
j2 = (j-1)*2 + 1
if (x(j,i) /= (j2 + 100*i2)*factor) call abort ()
end do
end do
end subroutine check_var_sec
end module m
program test
use m
implicit none
class(t1), allocatable :: x(:,:)
class(t2), allocatable :: y(:,:)
class(t3), allocatable :: z(:,:)
integer :: i, j
cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0; cnt3 = 0; cnt3e = 0
allocate (t1e :: x(10,10))
allocate (t2e :: y(10,10))
allocate (t3e :: z(10,10))
select type(x)
type is (t1e)
do i = 1, 10
do j = 1, 10
x(j,i)%i = j + 100*i
x(j,i)%j = (j + 100*i)*100
end do
end do
end select
select type(y)
type is (t2e)
do i = 1, 10
do j = 1, 10
y(j,i)%i = j + 100*i
y(j,i)%j = (j + 100*i)*100
end do
end do
end select
select type(z)
type is (t3e)
do i = 1, 10
do j = 1, 10
z(j,i)%i = j + 100*i
z(j,i)%j = (j + 100*i)*100
end do
end do
end select
if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
call fin_test_1(x(::2,::3))
if (cnt1 /= 5*4) call abort ()
if (cnt1e /= 5*4) call abort ()
cnt1 = 0; cnt1e = 0
if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
call fin_test_2(y(::2,::3))
if (cnt2 /= 1) call abort ()
if (cnt2e /= 1) call abort ()
cnt2 = 0; cnt2e = 0
if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) call abort()
call fin_test_3(z(::2,::3))
if (cnt3 /= 1) call abort ()
if (cnt3e /= 1) call abort ()
cnt3 = 0; cnt3e = 0
if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) call abort()
select type(x)
type is (t1e)
call check_val(x%i, 1)
call check_val(x%j, 100)
end select
select type(y)
type is (t2e)
call check_val(y%i, 1)
call check_val(y%j, 100)
end select
select type(z)
type is (t3e)
call check_val(z%i, 1)
call check_val(z%j, 100)
end select
contains
subroutine check_val(x, factor)
integer :: x(:,:)
integer, value :: factor
integer :: i, j
do i = 1, 10
do j = 1, 10
if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort ()
else
if (x(j,i) /= (j + 100*i)*factor) call abort ()
end if
end do
end do
end subroutine check_val
end program test
^ permalink raw reply [flat|nested] 9+ messages in thread
* *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-05-31 16:39 [Patch, Fortran] Finalize nonallocatables with INTENT(out) Tobias Burnus
2013-05-31 20:39 ` Tobias Burnus
@ 2013-06-06 8:35 ` Tobias Burnus
2013-06-08 11:11 ` Mikael Morin
2013-06-09 11:35 ` Andreas Schwab
1 sibling, 2 replies; 9+ messages in thread
From: Tobias Burnus @ 2013-06-06 8:35 UTC (permalink / raw)
To: fortran; +Cc: gcc patches
[-- Attachment #1: Type: text/plain, Size: 1050 bytes --]
* PING *
Attached is a rediff - including the later posted additional test case
(http://gcc.gnu.org/ml/fortran/2013-05/msg00141.html)
On May 31, 2013 18:39, Tobias Burnus wrote:
> This patch adds finalization support for INTENT(out) for
> nonallocatable dummy arguments.
>
> Additionally, it addresses a missed optimization: The previous code
> tried to deallocate allocatable components even if the dummy argument
> was already an allocatable. That's a missed optimization as gfortran
> deallocates allocatables in the caller.
>
> OK for the trunk?
>
> Note: This patch depends on
> http://gcc.gnu.org/ml/fortran/2013-05/msg00134.html
>
> Tobias
>
> PS: There are many more places where finalization should happen, e.g.
> intrinsic assignment (LHS + RHS func/constructor finalization),
> end-of-scope of nonallocatables. And some issues related coarrays,
> elemental+optional, etc.
> However, I stop here for the moment as I run out of time - and writing
> on-top patches of not reviewed/committed patches starts to become a
> chore.
[-- Attachment #2: final-intentout-v3.diff --]
[-- Type: text/x-patch, Size: 10961 bytes --]
2013-06-06 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans-decl.c (init_intent_out_dt): Call finalizer
when approriate.
2013-06-06 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.dg/finalize_10.f90: New.
* gfortran.dg/auto_dealloc_2.f90: Update tree-dump.
* gfortran.dg/finalize_15.f90: New.
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index b0e3ffc..72bb23f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3501,38 +3503,57 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = NULL_TREE;
+
+ /* Note: Allocatables are excluded as they are already handled
+ by the caller. */
+ if (!f->sym->attr.allocatable
+ && gfc_is_finalizable (f->sym->ts.u.derived, NULL))
{
- tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
- f->sym->backend_decl,
- f->sym->as ? f->sym->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
+ }
- if (f->sym->attr.optional
- || f->sym->ns->proc_name->attr.entry_master)
- {
- present = gfc_conv_expr_present (f->sym);
- tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
- present, tmp,
- build_empty_stmt (input_location));
- }
+ if (tmp == NULL_TREE && !f->sym->attr.allocatable
+ && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
+ tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
+ f->sym->backend_decl,
+ f->sym->as ? f->sym->as->rank : 0);
- gfc_add_expr_to_block (&init, tmp);
+ if (tmp != NULL_TREE && (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master))
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp, build_empty_stmt (input_location));
}
- else if (f->sym->value)
+
+ if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&init, tmp);
+ else if (f->sym->value && !f->sym->attr.allocatable)
gfc_init_default_dt (f->sym, &init, true);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
&& !CLASS_DATA (f->sym)->attr.class_pointer
- && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
+ && !CLASS_DATA (f->sym)->attr.allocatable)
{
- tmp = gfc_class_data_get (f->sym->backend_decl);
- if (CLASS_DATA (f->sym)->as == NULL)
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
- tmp,
- CLASS_DATA (f->sym)->as ?
- CLASS_DATA (f->sym)->as->rank : 0);
+ stmtblock_t block;
+ gfc_expr *e;
+
+ gfc_init_block (&block);
+ f->sym->attr.referenced = 1;
+ e = gfc_lval_expr_from_sym (f->sym);
+ gfc_add_finalizer_call (&block, e);
+ gfc_free_expr (e);
+ tmp = gfc_finish_block (&block);
if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
{
--- /dev/null 2013-06-06 09:52:08.544104880 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-06-03 12:32:38.763008261 +0200
@@ -0,0 +1,39 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/37336
+!
+! Finalize nonallocatable INTENT(OUT)
+!
+module m
+ type t
+ end type t
+ type t2
+ contains
+ final :: fini
+ end type t2
+contains
+ elemental subroutine fini(var)
+ type(t2), intent(inout) :: var
+ end subroutine fini
+end module m
+
+subroutine foo(x,y,aa,bb)
+ use m
+ class(t), intent(out) :: x(:),y
+ type(t2), intent(out) :: aa(:),bb
+end subroutine foo
+
+! Finalize CLASS + set default init
+! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
+
+! FINALIZE TYPE:
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&parm.\[0-9\]+, 0, 0);" 1 "original" } }
+! { dg!final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } }
+! { dg!final { scan-tree-dump-times "__final_m_T2 (&desc.\[0-9\]+, 0, 0);" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
index d261973..04ee7f2 100644
--- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
+++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90
@@ -25,5 +26,6 @@ contains
end program
-! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null 2013-06-06 09:52:08.544104880 +0200
+++ gcc/gcc/testsuite/gfortran.dg/finalize_15.f90 2013-05-31 22:29:58.958076041 +0200
@@ -0,0 +1,238 @@
+! { dg-do run }
+!
+! PR fortran/37336
+!
+! Check the scalarizer/array packing with strides
+! in the finalization wrapper
+!
+module m
+ implicit none
+
+ type t1
+ integer :: i
+ contains
+ final :: fini_elem
+ end type t1
+
+ type, extends(t1) :: t1e
+ integer :: j
+ contains
+ final :: fini_elem2
+ end type t1e
+
+ type t2
+ integer :: i
+ contains
+ final :: fini_shape
+ end type t2
+
+ type, extends(t2) :: t2e
+ integer :: j
+ contains
+ final :: fini_shape2
+ end type t2e
+
+ type t3
+ integer :: i
+ contains
+ final :: fini_explicit
+ end type t3
+
+ type, extends(t3) :: t3e
+ integer :: j
+ contains
+ final :: fini_explicit2
+ end type t3e
+
+ integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e
+
+contains
+
+ impure elemental subroutine fini_elem(x)
+ type(t1), intent(inout) :: x
+ integer :: i, j, i2, j2
+
+ if (cnt1e /= 5*4) call abort ()
+ j = mod (cnt1,5)+1
+ i = cnt1/5 + 1
+ i2 = (i-1)*3 + 1
+ j2 = (j-1)*2 + 1
+ if (x%i /= j2 + 100*i2) call abort ()
+ x%i = x%i * (-13)
+ cnt1 = cnt1 + 1
+ end subroutine fini_elem
+
+ impure elemental subroutine fini_elem2(x)
+ type(t1e), intent(inout) :: x
+ integer :: i, j, i2, j2
+
+ j = mod (cnt1e,5)+1
+ i = cnt1e/5 + 1
+ i2 = (i-1)*3 + 1
+ j2 = (j-1)*2 + 1
+ if (x%i /= j2 + 100*i2) call abort ()
+ if (x%j /= (j2 + 100*i2)*100) call abort ()
+ x%j = x%j * (-13)
+ cnt1e = cnt1e + 1
+ end subroutine fini_elem2
+
+ subroutine fini_shape(x)
+ type(t2) :: x(:,:)
+ if (cnt2e /= 1 .or. cnt2 /= 0) call abort ()
+ call check_var_sec(x%i, 1)
+ x%i = x%i * (-13)
+ cnt2 = cnt2 + 1
+ end subroutine fini_shape
+
+ subroutine fini_shape2(x)
+ type(t2e) :: x(:,:)
+ call check_var_sec(x%i, 1)
+ call check_var_sec(x%j, 100)
+ x%j = x%j * (-13)
+ cnt2e = cnt2e + 1
+ end subroutine fini_shape2
+
+ subroutine fini_explicit(x)
+ type(t3) :: x(5,4)
+ if (cnt3e /= 1 .or. cnt3 /= 0) call abort ()
+ call check_var_sec(x%i, 1)
+ x%i = x%i * (-13)
+ cnt3 = cnt3 + 1
+ end subroutine fini_explicit
+
+ subroutine fini_explicit2(x)
+ type(t3e) :: x(5,4)
+ call check_var_sec(x%i, 1)
+ call check_var_sec(x%j, 100)
+ x%j = x%j * (-13)
+ cnt3e = cnt3e + 1
+ end subroutine fini_explicit2
+
+ subroutine fin_test_1(x)
+ class(t1), intent(out) :: x(5,4)
+ end subroutine fin_test_1
+
+ subroutine fin_test_2(x)
+ class(t2), intent(out) :: x(:,:)
+ end subroutine fin_test_2
+
+ subroutine fin_test_3(x)
+ class(t3), intent(out) :: x(:,:)
+ if (any (shape(x) /= [5,4])) call abort ()
+ end subroutine fin_test_3
+
+ subroutine check_var_sec(x, factor)
+ integer :: x(:,:)
+ integer, value :: factor
+ integer :: i, j, i2, j2
+
+ do i = 1, 4
+ i2 = (i-1)*3 + 1
+ do j = 1, 5
+ j2 = (j-1)*2 + 1
+ if (x(j,i) /= (j2 + 100*i2)*factor) call abort ()
+ end do
+ end do
+ end subroutine check_var_sec
+end module m
+
+
+program test
+ use m
+ implicit none
+
+ class(t1), allocatable :: x(:,:)
+ class(t2), allocatable :: y(:,:)
+ class(t3), allocatable :: z(:,:)
+ integer :: i, j
+
+ cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0; cnt3 = 0; cnt3e = 0
+
+ allocate (t1e :: x(10,10))
+ allocate (t2e :: y(10,10))
+ allocate (t3e :: z(10,10))
+
+ select type(x)
+ type is (t1e)
+ do i = 1, 10
+ do j = 1, 10
+ x(j,i)%i = j + 100*i
+ x(j,i)%j = (j + 100*i)*100
+ end do
+ end do
+ end select
+
+ select type(y)
+ type is (t2e)
+ do i = 1, 10
+ do j = 1, 10
+ y(j,i)%i = j + 100*i
+ y(j,i)%j = (j + 100*i)*100
+ end do
+ end do
+ end select
+
+ select type(z)
+ type is (t3e)
+ do i = 1, 10
+ do j = 1, 10
+ z(j,i)%i = j + 100*i
+ z(j,i)%j = (j + 100*i)*100
+ end do
+ end do
+ end select
+
+ if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
+
+ call fin_test_1(x(::2,::3))
+ if (cnt1 /= 5*4) call abort ()
+ if (cnt1e /= 5*4) call abort ()
+ cnt1 = 0; cnt1e = 0
+ if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
+
+ call fin_test_2(y(::2,::3))
+ if (cnt2 /= 1) call abort ()
+ if (cnt2e /= 1) call abort ()
+ cnt2 = 0; cnt2e = 0
+ if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) call abort()
+
+ call fin_test_3(z(::2,::3))
+ if (cnt3 /= 1) call abort ()
+ if (cnt3e /= 1) call abort ()
+ cnt3 = 0; cnt3e = 0
+ if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) call abort()
+
+ select type(x)
+ type is (t1e)
+ call check_val(x%i, 1)
+ call check_val(x%j, 100)
+ end select
+
+ select type(y)
+ type is (t2e)
+ call check_val(y%i, 1)
+ call check_val(y%j, 100)
+ end select
+
+ select type(z)
+ type is (t3e)
+ call check_val(z%i, 1)
+ call check_val(z%j, 100)
+ end select
+
+contains
+ subroutine check_val(x, factor)
+ integer :: x(:,:)
+ integer, value :: factor
+ integer :: i, j
+ do i = 1, 10
+ do j = 1, 10
+ if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
+ if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort ()
+ else
+ if (x(j,i) /= (j + 100*i)*factor) call abort ()
+ end if
+ end do
+ end do
+ end subroutine check_val
+end program test
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-06-06 8:35 ` *PING* / " Tobias Burnus
@ 2013-06-08 11:11 ` Mikael Morin
2013-06-08 12:40 ` Tobias Burnus
2013-06-09 11:35 ` Andreas Schwab
1 sibling, 1 reply; 9+ messages in thread
From: Mikael Morin @ 2013-06-08 11:11 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc patches
Hello,
Le 06/06/2013 10:35, Tobias Burnus a écrit :
> * PING *
>
> Attached is a rediff - including the later posted additional test case
> (http://gcc.gnu.org/ml/fortran/2013-05/msg00141.html)
>
>
> On May 31, 2013 18:39, Tobias Burnus wrote:
>> This patch adds finalization support for INTENT(out) for
>> nonallocatable dummy arguments.
>>
>> Additionally, it addresses a missed optimization: The previous code
>> tried to deallocate allocatable components even if the dummy argument
>> was already an allocatable. That's a missed optimization as gfortran
>> deallocates allocatables in the caller.
>>
Is there any reason to handle them in the caller?
The patch is OK.
Mikael
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-06-08 11:11 ` Mikael Morin
@ 2013-06-08 12:40 ` Tobias Burnus
0 siblings, 0 replies; 9+ messages in thread
From: Tobias Burnus @ 2013-06-08 12:40 UTC (permalink / raw)
To: Mikael Morin; +Cc: fortran, gcc patches
Hello Mikael,
thanks for your patch reviews! Regarding your question:
Mikael Morin worte:
> Le 06/06/2013 10:35, Tobias Burnus a écrit :
>> On May 31, 2013 18:39, Tobias Burnus wrote:
>>> This patch adds finalization support for INTENT(out) for
>>> nonallocatable dummy arguments.
>>>
>>> Additionally, it addresses a missed optimization: The previous code
>>> tried to deallocate allocatable components even if the dummy argument
>>> was already an allocatable. That's a missed optimization as gfortran
>>> deallocates allocatables in the caller.
>>>
> Is there any reason to handle them in the caller?
I don't think that there is real reason - and I don't know why Erik
Edelmann and Paul have chosen to do so for GCC 4.2. In principle, either
location is fine. I think I had placed it into the callee, but now we
cannot change it anymore without breaking the ABI.
For TS29113 (i.e. for bind(C)), the Fortran procedure has to handle the
deallocate for allocatable dummys with intent(out). Thus, in that case,
one needs to have the deallocation code both in the caller and in the
callee. (TS29113 only permits interoperable types with ALLOCATABLE or
INTENT(OUT) - noninteroperable vars (i.e. extensible types, allocatable
components, finalizers etc.) can be used in BIND(C) procedures - but
only with the dummy argument TYPE(*) - and hence without ALLOCATABLE and
INTENT(OUT)).
Tobias
PS: Pending patches:
* 4.8/4.9 regression: http://gcc.gnu.org/ml/fortran/2013-06/msg00047.html
* CLASS as result var: http://gcc.gnu.org/ml/fortran/2013-06/msg00053.html
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-06-06 8:35 ` *PING* / " Tobias Burnus
2013-06-08 11:11 ` Mikael Morin
@ 2013-06-09 11:35 ` Andreas Schwab
1 sibling, 0 replies; 9+ messages in thread
From: Andreas Schwab @ 2013-06-09 11:35 UTC (permalink / raw)
To: Tobias Burnus; +Cc: fortran, gcc patches
Tobias Burnus <burnus@net-b.de> writes:
> --- /dev/null 2013-06-06 09:52:08.544104880 +0200
> +++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-06-03 12:32:38.763008261 +0200
> @@ -0,0 +1,39 @@
> +! { dg-do compile }
> +! { dg-options "-fdump-tree-original" }
> +!
> +! PR fortran/37336
> +!
> +! Finalize nonallocatable INTENT(OUT)
> +!
> +module m
> + type t
> + end type t
> + type t2
> + contains
> + final :: fini
> + end type t2
> +contains
> + elemental subroutine fini(var)
> + type(t2), intent(inout) :: var
> + end subroutine fini
> +end module m
> +
> +subroutine foo(x,y,aa,bb)
> + use m
> + class(t), intent(out) :: x(:),y
> + type(t2), intent(out) :: aa(:),bb
> +end subroutine foo
> +
> +! Finalize CLASS + set default init
> +! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
> +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
That doesn't match.
(void) __builtin_memcpy ((void *) y->_data, (void *) y->_vptr->_def_init, (character(kind=4)) y->_vptr->_size);
Appears to be a 32/64 bit issue.
Andreas.
--
Andreas Schwab, schwab@linux-m68k.org
GPG Key fingerprint = 58CA 54C7 6D53 942B 1756 01D3 44D5 214B 8276 4ED5
"And now for something completely different."
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-06-12 13:18 ` Tobias Burnus
@ 2013-06-12 13:29 ` Tobias Burnus
0 siblings, 0 replies; 9+ messages in thread
From: Tobias Burnus @ 2013-06-12 13:29 UTC (permalink / raw)
To: Dominique Dhumieres; +Cc: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 376 bytes --]
Tobias Burnus wrote:
> Dominique Dhumieres wrote:
>> I have tried to weaken the test by not using any target and using a
>> regexp
>> of the kind "(int|long)", but I did not succeeded.
Ups, I missed that Dominique's and Andreas' 32bit dumps are different
("unsigned int" vs. "character(kind=4)"). Thus, the new pattern accepts
either version. Committed as 200006.
Tobias
[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 1585 bytes --]
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 200003)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,7 +1,11 @@
2013-06-12 Tobias Burnus <burnus@net-b.de>
+
+ * gfortran.dg/finalize_10.f90: Update scan-tree-dump.
+
+2013-06-12 Tobias Burnus <burnus@net-b.de>
Dominique d'Humieres <dominiq@lps.ens.fr>
- * gfortran.dg/finalize_10.f90: Update dg-dump.
+ * gfortran.dg/finalize_10.f90: Update scan-tree-dump.
2013-06-12 Jakub Jelinek <jakub@redhat.com>
Index: gcc/testsuite/gfortran.dg/finalize_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_10.f90 (Revision 200003)
+++ gcc/testsuite/gfortran.dg/finalize_10.f90 (Arbeitskopie)
@@ -26,7 +26,7 @@
! Finalize CLASS + set default init
! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned (long|int)\\) y->_vptr->_size\\);" "original" } }
+! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\((unsigned long|unsigned int|character\\(kind=4\\))\\) y->_vptr->_size\\);" "original" } }
! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
2013-06-09 10:46 Dominique Dhumieres
@ 2013-06-12 13:18 ` Tobias Burnus
2013-06-12 13:29 ` Tobias Burnus
0 siblings, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2013-06-12 13:18 UTC (permalink / raw)
To: Dominique Dhumieres; +Cc: fortran, gcc-patches, hjl.tools, mikael.morin
[-- Attachment #1: Type: text/plain, Size: 482 bytes --]
Thanks Dominique and Andreas for reporting this issue.
Dominique Dhumieres wrote:
> The test gfortran.dg/finalize_10.f90 fails in 32 bit mode [...]
> The following patch fixes it
> [...]
>
> I have tried to weaken the test by not using any target and using a regexp
> of the kind "(int|long)", but I did not succeeded.
Seemingly, dg-tree-dump-times does not work with regular expressions. I
have replaces it by dg-tree-dump + regular expression.
Committed as 200003.
Tobias
[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 1405 bytes --]
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 200002)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,8 @@
+2013-06-12 Tobias Burnus <burnus@net-b.de>
+ Dominique d'Humieres <dominiq@lps.ens.fr>
+
+ * gfortran.dg/finalize_10.f90: Update dg-dump.
+
2013-06-12 Jakub Jelinek <jakub@redhat.com>
PR target/56564
Index: gcc/testsuite/gfortran.dg/finalize_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_10.f90 (Revision 200002)
+++ gcc/testsuite/gfortran.dg/finalize_10.f90 (Arbeitskopie)
@@ -26,7 +26,7 @@
! Finalize CLASS + set default init
! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned (long|int)\\) y->_vptr->_size\\);" "original" } }
! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)
@ 2013-06-09 10:46 Dominique Dhumieres
2013-06-12 13:18 ` Tobias Burnus
0 siblings, 1 reply; 9+ messages in thread
From: Dominique Dhumieres @ 2013-06-09 10:46 UTC (permalink / raw)
To: fortran; +Cc: gcc-patches, hjl.tools, mikael.morin, burnus
Dear Tobias,
The test gfortran.dg/finalize_10.f90 fails in 32 bit mode (see
http://gcc.gnu.org/ml/gcc-testresults/2013-06/msg00842.html
FAIL: gfortran.dg/finalize_10.f90 -O scan-tree-dump-times original "__builtin_memcpy \\\\(\\\\(void .\\\\) y->_data, \\\\(void .\\\\) y->_vptr->_def_init, \\\\(unsigned long\\\\) y->_vptr->_size\\\\);" 1)
because "unsigned long" is replaced with "unsigned int".
The following patch fixes it
--- ../_clean/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-06-08 21:50:32.000000000 +0200
+++ gcc/testsuite/gfortran.dg/finalize_10.f90 2013-06-09 11:33:12.000000000 +0200
@@ -26,7 +26,8 @@ end subroutine foo
! Finalize CLASS + set default init
! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned long\\) y->_vptr->_size\\);" 1 "original" { target lp64 } } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\(unsigned int\\) y->_vptr->_size\\);" 1 "original" { target ilp32 } } }
! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
I have tried to weaken the test by not using any target and using a regexp
of the kind "(int|long)", but I did not succeeded.
CAVEAT: I don't know if the targets work for x32.
TIA
Dominique
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2013-06-12 13:29 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-05-31 16:39 [Patch, Fortran] Finalize nonallocatables with INTENT(out) Tobias Burnus
2013-05-31 20:39 ` Tobias Burnus
2013-06-06 8:35 ` *PING* / " Tobias Burnus
2013-06-08 11:11 ` Mikael Morin
2013-06-08 12:40 ` Tobias Burnus
2013-06-09 11:35 ` Andreas Schwab
2013-06-09 10:46 Dominique Dhumieres
2013-06-12 13:18 ` Tobias Burnus
2013-06-12 13:29 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).