Patchwork [Fortran] RFC patch for gfc_trans_deferred_vars (PR 48786)

login
register
mail settings
Submitter Tobias Burnus
Date April 29, 2011, 9:46 p.m.
Message ID <4DBB31BC.5000804@net-b.de>
Download mbox | patch
Permalink /patch/93482/
State New
Headers show

Comments

Tobias Burnus - April 29, 2011, 9:46 p.m.
Dear all,

gfc_trans_deferred_vars is a bit of a mess; there is first a block which 
handles function results of the type proc_sym->result == proc_sym. 
Afterwards, deferred variables - local, dummys, and proc_sym->result (!= 
proc_sym) are handled.

The problem is that for allocatable results (esp. of CLASS type) and for 
deferred-length strings, the same initialization has to happen as for 
function results.

Consequence: There is code partial duplication - and some code should be 
duplicated, but is not; that causes the issue with the current code.

Attached patch tries to fix that; it fixes Arjan's wrong-code issue and 
it also reduces the code size; however, I do not think that it makes the 
code very readable.

What do you think? How can this be improved? Or should the patch be 
committed as is? (The patch was regtested on x86-64-linux.)

Tobias
! { dg-do run }
!
! PR fortran/24141
!
! Contributed by Arjen Markus; the trace module
! is from Simon Geard. 
!

! -------------------------------------
! Copyright 2011 Simon Geard. All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!    1. Redistributions of source code must retain the above copyright notice, this list of
!       conditions and the following disclaimer.
!
!    2. Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials
!       provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY <COPYRIGHT HOLDER> ``AS IS'' AND ANY EXPRESS OR IMPLIED
! WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module trace
  implicit none
  type tracing
     integer           :: level = 0
     character(len=3)  :: indent = '   '

   contains
     procedure, public :: in
     procedure, public :: out
     procedure, public :: message
     procedure, public :: get_current_indent
     procedure, public :: print_current_indent
  end type tracing

  type(tracing), public :: tr
  logical, private      :: s_trace_is_on = .false.

contains

  subroutine set_trace_on
    s_trace_is_on = .true.
  end subroutine set_trace_on

  subroutine set_trace_off
    s_trace_is_on = .false.
  end subroutine set_trace_off

  logical function trace_is_on()
    trace_is_on = s_trace_is_on
  end function trace_is_on

  subroutine in(this, name)
    implicit none
    class(tracing), intent(inout) :: this
    character(len=*), intent(in) :: name
    if (s_trace_is_on) then
       write(*,'(a)') repeat(this%indent,this%level)//name//'<in>'
    end if
    this%level = this%level + 1
  end subroutine in

  subroutine out(this, no_message)
    implicit none
    class(tracing), intent(inout) :: this
    logical, optional             :: no_message ! = .true.
    logical :: output_mess
    this%level = this%level - 1
    if (s_trace_is_on) then
       output_mess = merge(no_message, .true., present(no_message))
       if (output_mess) write(*,'(a)') repeat(this%indent,this%level)//'<out>'
    end if
  end subroutine out

  subroutine message(this, mess)
    class(tracing), intent(in)   :: this
    character(len=*), intent(in) :: mess
    if (s_trace_is_on) then
       write(*,'(a)') repeat(this%indent,this%level)//mess
    end if
  end subroutine message

  subroutine print_current_indent(this)
    class(tracing), intent(in)    :: this
    if (this%level > 0) then
       write(*,advance='no',fmt = '(a)') repeat(this%indent,this%level)
    end if
  end subroutine print_current_indent

  subroutine get_current_indent(this, indent, nindent)
    class(tracing), intent(in)    :: this
    character(len=*), intent(out) :: indent
    integer, intent(out)          :: nindent
    indent = repeat(this%indent,this%level)
    nindent = len(this%indent)*this%level
  end subroutine get_current_indent
end module trace

module points2d3d
  use trace
  implicit none

  type point2d
     real :: x, y
   contains
     procedure               :: print           => print_2d
     procedure               :: add_vector      => add_vector_2d
     procedure               :: random          => random_vector_2d
     procedure               :: assign          => assign_2d
     generic, public         :: operator(+)     => add_vector
     generic, public         :: assignment(=)   => assign
  end type point2d

  type, extends(point2d) :: point3d
     real :: z
   contains
     procedure               :: print           => print_3d
     procedure               :: add_vector      => add_vector_3d
     procedure               :: random          => random_vector_3d
     procedure               :: assign          => assign_3d
!!   generic, public         :: operator(+) => add_vector
!!   generic, public         :: assignment(=)   => assign
  end type point3d

contains
  subroutine print_2d( point )
    class(point2d) :: point

    write(*,'(2f10.4)') point%x, point%y
  end subroutine print_2d

  subroutine print_3d( point )
    class(point3d) :: point

    write(*,'(3f10.4)') point%x, point%y, point%z
  end subroutine print_3d

  subroutine random_vector_2d( point )
    class(point2d) :: point

    call random_number( point%x )
    call random_number( point%y )

    point%x = 2.0 * point%x - 1.0
    point%y = 2.0 * point%y - 1.0

  end subroutine random_vector_2d

  !
  ! This routine gets confused for the 2D variant
  ! - essentially the same interface?
  subroutine random_vector_3d( point )
    class(point3d) :: point

    call point%point2d%random
    call random_number( point%z )

    point%z = 2.0 * point%z - 1.0

  end subroutine random_vector_3d

function add_vector_2d( point, vector )
    class(point2d), intent(in)  :: point, vector
    class(point2d), allocatable :: add_vector_2d

    if ( allocated(add_vector_2d) ) then
        deallocate( add_vector_2d )
    endif
    allocate( add_vector_2d )
    add_vector_2d%x = point%x + vector%x
    add_vector_2d%y = point%y + vector%y
  end function add_vector_2d

  function add_vector_3d( point, vector )
    class(point3d), intent(in)  :: point
    class(point2d), intent(in)  :: vector

    class(point3d), allocatable :: vector_3d
    class(point2d), allocatable :: add_vector_3d

    allocate( vector_3d )

    select type (vector)
        class is (point3d)
            vector_3d%point2d = point%point2d + vector%point2d
            vector_3d%z       = point%z       + vector%z
    end select

    call move_alloc( vector_3d, add_vector_3d )

  end function add_vector_3d


  subroutine assign_2d( left, right )
    class(point2d), intent(inout) :: left
    class(point2d), intent(in)    :: right

    left%x = right%x
    left%y = right%y
  end subroutine assign_2d

  subroutine assign_3d( left, right )
    class(point3d), intent(inout) :: left
    class(point2d), intent(in)    :: right

    select type (right)
        type is (point3d)
            left%point2d = right%point2d
            left%z       = right%z
    end select

  end subroutine assign_3d

end module points2d3d

program random_walk

  use points2d3d   ! Both 2D and 3D points available

  type(point2d), target   :: point_2d, vector_2d
  type(point3d), target   :: point_3d, vector_3d

!
  ! A variable of class point2d can point to point_2d but
  ! also to point_3d
  !
  class(point2d), pointer :: point, vector

  integer        :: nsteps = 3 ! Was 10
  integer        :: i
  integer        :: trial
  real           :: deltt  = 0.1

  ! Select what type of point ...

  do trial = 1,2
     if (trial == 1) then
        write(*,*) 'Two-dimensional walk:'
        point => point_2d
        vector => vector_2d
     else
        ! Now let's take a 3D walk ...
        write(*,*) 'Three-dimensional walk:'
        point => point_3d
        vector => vector_3d
     end if

     call point%random

     do i = 1,nsteps
        call vector%random

        point = point + vector

        call point%print
     enddo
  enddo

end program random_walk

! { dg-final { cleanup-modules "trace points2d3d" } }
Paul Richard Thomas - May 1, 2011, 6:52 a.m.
Dear Tobias,

I applied your patch and have the following comments:

On Fri, Apr 29, 2011 at 11:46 PM, Tobias Burnus <burnus@net-b.de> wrote:
> Dear all,
>
> gfc_trans_deferred_vars is a bit of a mess; there is first a block which
> handles function results of the type proc_sym->result == proc_sym.
> Afterwards, deferred variables - local, dummys, and proc_sym->result (!=
> proc_sym) are handled.
>
> The problem is that for allocatable results (esp. of CLASS type) and for
> deferred-length strings, the same initialization has to happen as for
> function results.

Yes, I agree that this has become something of a mess.

>
> Consequence: There is code partial duplication - and some code should be
> duplicated, but is not; that causes the issue with the current code.
>
> Attached patch tries to fix that; it fixes Arjan's wrong-code issue and it
> also reduces the code size; however, I do not think that it makes the code
> very readable.

I don't think that it makes it less readable :-)

>
> What do you think? How can this be improved? Or should the patch be
> committed as is? (The patch was regtested on x86-64-linux.)

Originally, gfc_trans_deferred_vars had very little code within the
conditional blocks - mainly, there were calls to appropriately named
functions.  The naming was intended to expose the logic.  I would
suggest that you do likewise.  It's something of a no-brainer as far
as its implementation is concerned and it certainly makes the logic
stand out more.  There are various other parts of ~/gcc/fortran that
could stand the same treatment!

On the wrong-code issue:  I could not see any difference in behaviour
using your testcase between trunk with your patch and 4.6.0 without.
I have yet to return to Arjen's original and will report when I have
done.

Anyway, thanks for looking at the PR and cleaning up gfc_trans_deferred_vars.

Paul

Patch

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index f80c9db..3db38eb 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3355,7 +3355,7 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
   gfc_symbol *sym;
   gfc_formal_arglist *f;
   stmtblock_t tmpblock;
-  bool seen_trans_deferred_array = false;
+  bool seen_trans_deferred_array = false, processed_proc = false;
   tree tmp = NULL;
   gfc_expr *e;
   gfc_se se;
@@ -3391,37 +3391,8 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if (proc_sym->ts.type == BT_CHARACTER)
 	{
-	  if (proc_sym->ts.deferred)
-	    {
-	      tmp = NULL;
-	      gfc_save_backend_locus (&loc);
-	      gfc_set_backend_locus (&proc_sym->declared_at);
-	      gfc_start_block (&init);
-	      /* Zero the string length on entry.  */
-	      gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
-			      build_int_cst (gfc_charlen_type_node, 0));
-	      /* Null the pointer.  */
-	      e = gfc_lval_expr_from_sym (proc_sym);
-	      gfc_init_se (&se, NULL);
-	      se.want_pointer = 1;
-	      gfc_conv_expr (&se, e);
-	      gfc_free_expr (e);
-	      tmp = se.expr;
-	      gfc_add_modify (&init, tmp,
-			      fold_convert (TREE_TYPE (se.expr),
-					    null_pointer_node));
-	      gfc_restore_backend_locus (&loc);
-
-	      /* Pass back the string length on exit.  */
-	      tmp = proc_sym->ts.u.cl->passed_length;
-	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
-	      tmp = fold_convert (gfc_charlen_type_node, tmp);
-	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
-				     gfc_charlen_type_node, tmp,
-				     proc_sym->ts.u.cl->backend_decl);
-	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
-	    }
-	  else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+	  if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL
+	      && !proc_sym->ts.deferred)
 	    gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
 	}
       else
@@ -3437,14 +3408,32 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
   init_intent_out_dt (proc_sym, block);
   gfc_restore_backend_locus (&loc);
 
-  for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
+  for (sym = proc_sym->tlink; ; sym = sym->tlink)
     {
       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
 				   && sym->ts.u.derived->attr.alloc_comp;
       if (sym->assoc)
 	continue;
 
-      if (sym->attr.dimension)
+      /* Handle sym == proc_sym only once to avoid an endless loop.  */
+      if (sym == proc_sym)
+	{
+	  if (processed_proc)
+	    break;
+	  processed_proc = true;
+	}
+
+      /* For function results, which do not need an initialization,
+	 end the loop.  */
+      if (sym == proc_sym
+	  && (sym != proc_sym->result
+	      || !(sym->attr.allocatable || sym->ts.deferred
+		   || sym_has_alloc_comp
+		   || (sym->ts.type == BT_CLASS
+		       && CLASS_DATA (sym)->attr.allocatable))))
+	break;
+
+      if (sym->attr.dimension && sym != proc_sym)
 	{
 	  switch (sym->as->type)
 	    {
@@ -3521,7 +3510,7 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	  if (sym_has_alloc_comp && !seen_trans_deferred_array)
 	    gfc_trans_deferred_array (sym, block);
 	}
-      else if ((!sym->attr.dummy || sym->ts.deferred)
+      else if (! sym->attr.dimension && (!sym->attr.dummy || sym->ts.deferred)
 		&& (sym->attr.allocatable
 		    || (sym->ts.type == BT_CLASS
 			&& CLASS_DATA (sym)->attr.allocatable)))
@@ -3551,9 +3540,9 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 					        null_pointer_node));
 		}
 
-	      if ((sym->attr.dummy ||sym->attr.result)
-		    && sym->ts.type == BT_CHARACTER
-		    && sym->ts.deferred)
+	      if ((sym->attr.dummy || sym->attr.result || sym == proc_sym)
+		  && sym->ts.type == BT_CHARACTER
+		  && sym->ts.deferred)
 		{
 		  /* Character length passed by reference.  */
 		  tmp = sym->ts.u.cl->passed_length;
@@ -3582,7 +3571,7 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 
 	      /* Deallocate when leaving the scope. Nullifying is not
 		 needed.  */
-	      if (!sym->attr.result && !sym->attr.dummy)
+	      if (!sym->attr.result && sym != proc_sym && !sym->attr.dummy)
 		tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
 							 NULL, sym->ts);
 
@@ -3638,9 +3627,9 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if (sym->ts.deferred)
 	gfc_fatal_error ("Deferred type parameter not yet supported");
-      else if (sym_has_alloc_comp)
+      else if (sym_has_alloc_comp && proc_sym != sym)
 	gfc_trans_deferred_array (sym, block);
-      else if (sym->ts.type == BT_CHARACTER)
+      else if (sym->ts.type == BT_CHARACTER && sym != proc_sym)
 	{
 	  gfc_save_backend_locus (&loc);
 	  gfc_set_backend_locus (&sym->declared_at);
@@ -3667,7 +3656,7 @@  gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
 				NULL_TREE);
 	}
-      else
+      else if (proc_sym != sym)
 	gcc_unreachable ();
     }