Patchwork *PING* / Re: [Patch, Fortran] Finalize nonallocatables with INTENT(out)

login
register
mail settings
Submitter Tobias Burnus
Date June 6, 2013, 8:35 a.m.
Message ID <51B049CA.80202@net-b.de>
Download mbox | patch
Permalink /patch/249319/
State New
Headers show

Comments

Tobias Burnus - June 6, 2013, 8:35 a.m.
* 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.
Mikael Morin - June 8, 2013, 11:10 a.m.
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
Tobias Burnus - June 8, 2013, 12:39 p.m.
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
Andreas Schwab - June 9, 2013, 11:35 a.m.
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.

Patch

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