[Patch, fortran] PR67177, 67977 and memory leaks in move_alloc

[Patch, fortran] PR67177, 67977 and memory leaks in move_alloc

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 1657 bytes --]

Dear All,

I was moved by a report on clf of memory leaks in move_alloc to
investigate the cause. This turned out to be trivial but led to the
above PRs, which themselves were trivial. The result is the attached
patch. I am aware that I have not investigated the further
ramifications that I can imagine are there. Rather, I thought just to
fix the reported problems.

It should be noted that there is no PR directly associated with the
memory leaks. Since the standard does not require this, I did not
think that it was worthwhile to raise a PR and then close it!

Bootstraps and regtests on FC21/x86_64 - OK for trunk? ... and 5.2
after a decent interval?

Cheers

Paul

2015-10-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/67177
    PR fortran/67977
    * primary.c (match_substring): Add an argument 'deferred' to
    flag that a substring reference with null start and end should
    not be optimized away for deferred length strings.
    (match_string_constant, gfc_match_rvalue): Set the argument.
    * trans-expr.c (alloc_scalar_allocatable_for_assignment): If
    there is a substring reference return.
    * trans-intrinsic.c (conv_intrinsic_move_alloc): For deferred
    characters, assign the 'from' string length to the 'to' string
    length. If the 'from' expression is deferred, set its string
    length to zero. If the 'to' expression has allocatable
    components, deallocate them.

2015-10-17  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/67177
    * gfortran.dg/move_alloc_15.f90: New test
    * gfortran.dg/move_alloc_16.f90: New test

    PR fortran/67977
    * gfortran.dg/deferred_character_assignment_1.f90: New test

[-- Attachment #2: submit.diff --]
[-- Type: text/plain, Size: 10426 bytes --]

Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 228849)
--- gcc/fortran/primary.c	(working copy)
*************** cleanup:
*** 800,806 ****
  /* Match a substring reference.  */
  
  static match
! match_substring (gfc_charlen *cl, int init, gfc_ref **result)
  {
    gfc_expr *start, *end;
    locus old_loc;
--- 800,806 ----
  /* Match a substring reference.  */
  
  static match
! match_substring (gfc_charlen *cl, int init, gfc_ref **result, bool deferred)
  {
    gfc_expr *start, *end;
    locus old_loc;
*************** match_substring (gfc_charlen *cl, int in
*** 852,858 ****
      }
  
    /* Optimize away the (:) reference.  */
!   if (start == NULL && end == NULL)
      ref = NULL;
    else
      {
--- 852,858 ----
      }
  
    /* Optimize away the (:) reference.  */
!   if (start == NULL && end == NULL && !deferred)
      ref = NULL;
    else
      {
*************** got_delim:
*** 1150,1156 ****
    if (ret != -1)
      gfc_internal_error ("match_string_constant(): Delimiter not found");
  
!   if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
      e->expr_type = EXPR_SUBSTRING;
  
    *result = e;
--- 1150,1156 ----
    if (ret != -1)
      gfc_internal_error ("match_string_constant(): Delimiter not found");
  
!   if (match_substring (NULL, 0, &e->ref, false) != MATCH_NO)
      e->expr_type = EXPR_SUBSTRING;
  
    *result = e;
*************** check_substring:
*** 2133,2139 ****
  
    if (primary->ts.type == BT_CHARACTER)
      {
!       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
  	{
  	case MATCH_YES:
  	  if (tail == NULL)
--- 2133,2140 ----
  
    if (primary->ts.type == BT_CHARACTER)
      {
!       bool def = primary->ts.deferred == 1;
!       switch (match_substring (primary->ts.u.cl, equiv_flag, &substring, def))
  	{
  	case MATCH_YES:
  	  if (tail == NULL)
*************** gfc_match_rvalue (gfc_expr **result)
*** 3147,3153 ****
  	     that we're not sure is a variable yet.  */
  
  	  if ((implicit_char || sym->ts.type == BT_CHARACTER)
! 	      && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
  	    {
  
  	      e->expr_type = EXPR_VARIABLE;
--- 3148,3154 ----
  	     that we're not sure is a variable yet.  */
  
  	  if ((implicit_char || sym->ts.type == BT_CHARACTER)
! 	      && match_substring (sym->ts.u.cl, 0, &e->ref, false) == MATCH_YES)
  	    {
  
  	      e->expr_type = EXPR_VARIABLE;
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 228849)
--- gcc/fortran/trans-expr.c	(working copy)
*************** alloc_scalar_allocatable_for_assignment
*** 8891,8896 ****
--- 8891,8897 ----
    tree jump_label1;
    tree jump_label2;
    gfc_se lse;
+   gfc_ref *ref;
  
    if (!expr1 || expr1->rank)
      return;
*************** alloc_scalar_allocatable_for_assignment
*** 8898,8903 ****
--- 8899,8908 ----
    if (!expr2 || expr2->rank)
      return;
  
+   for (ref = expr1->ref; ref; ref = ref->next)
+     if (ref->type == REF_SUBSTRING)
+       return;
+ 
    realloc_lhs_warning (expr2->ts.type, false, &expr2->where);
  
    /* Since this is a scalar lhs, we can afford to do this.  That is,
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 228849)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 9414,9419 ****
--- 9414,9429 ----
  	    }
  	}
  
+       if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
+ 	{
+ 	  gfc_add_modify_loc (input_location, &block, to_se.string_length,
+ 			      fold_convert (TREE_TYPE (to_se.string_length),
+ 					    from_se.string_length));
+ 	  if (from_expr->ts.deferred)
+ 	    gfc_add_modify_loc (input_location, &block, from_se.string_length,
+ 			build_int_cst (TREE_TYPE (from_se.string_length), 0));
+ 	}
+ 
        return gfc_finish_block (&block);
      }
  
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 9513,9518 ****
--- 9523,9536 ----
      }
    else
      {
+       if (to_expr->ts.type == BT_DERIVED
+ 	  && to_expr->ts.u.derived->attr.alloc_comp)
+ 	{
+ 	  tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
+ 					   to_se.expr, to_expr->rank);
+ 	  gfc_add_expr_to_block (&block, tmp);
+ 	}
+ 
        tmp = gfc_conv_descriptor_data_get (to_se.expr);
        tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
  					NULL_TREE, true, to_expr, false);
*************** conv_intrinsic_move_alloc (gfc_code *cod
*** 9527,9532 ****
--- 9545,9561 ----
    gfc_add_modify_loc (input_location, &block, tmp,
  		      fold_convert (TREE_TYPE (tmp), null_pointer_node));
  
+ 
+   if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
+     {
+       gfc_add_modify_loc (input_location, &block, to_se.string_length,
+ 			  fold_convert (TREE_TYPE (to_se.string_length),
+ 					from_se.string_length));
+       if (from_expr->ts.deferred)
+         gfc_add_modify_loc (input_location, &block, from_se.string_length,
+ 			build_int_cst (TREE_TYPE (from_se.string_length), 0));
+     }
+ 
    return gfc_finish_block (&block);
  }
  
Index: gcc/testsuite/gfortran.dg/move_alloc_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/move_alloc_15.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/move_alloc_15.f90	(working copy)
***************
*** 0 ****
--- 1,88 ----
+ ! { dg-do run }
+ ! { dg-options "-fdump-tree-original" }
+ !
+ ! Fix for PR......
+ !
+ ! The 'to' components of 'mytemp' would remain allocated after the call to
+ ! MOVE_ALLOC, resulting in memory leaks.
+ !
+ ! Contributed by Alberto Luaces.
+ !
+ ! See https://groups.google.com/forum/#!topic/comp.lang.fortran/k3bkKUbOpFU
+ !
+ module alloctest
+   type myallocatable
+      integer, allocatable:: i(:)
+   end type myallocatable
+ 
+ contains
+   subroutine f(num, array)
+     implicit none
+     integer, intent(in) :: num
+     integer :: i
+     type(myallocatable):: array(:)
+ 
+     do i = 1, num
+        allocate(array(i)%i(5), source = [1,2,3,4,5])
+     end do
+ 
+   end subroutine f
+ end module alloctest
+ 
+ program name
+   use alloctest
+   implicit none
+   type(myallocatable), allocatable:: myarray(:), mytemp(:)
+   integer, parameter:: OLDSIZE = 7, NEWSIZE = 20
+   logical :: flag
+ 
+   allocate(myarray(OLDSIZE))
+   call f(size(myarray), myarray)
+ 
+   allocate(mytemp(NEWSIZE))
+   mytemp(1:OLDSIZE) = myarray
+ 
+   flag = .false.
+   call foo
+   call bar
+ 
+   deallocate(myarray)
+   if (allocated (mytemp)) deallocate (mytemp)
+ 
+   allocate(myarray(OLDSIZE))
+   call f(size(myarray), myarray)
+ 
+   allocate(mytemp(NEWSIZE))
+   mytemp(1:OLDSIZE) = myarray
+ 
+ ! Verfify that there is no segfault if the allocatable components
+ ! are deallocated before the call to move_alloc
+   flag = .true.
+   call foo
+   call bar
+ 
+   deallocate(myarray)
+ contains
+   subroutine foo
+     integer :: i
+     if (flag) then
+       do i = 1, OLDSIZE
+         deallocate (mytemp(i)%i)
+       end do
+     end if
+     call move_alloc(mytemp, myarray)
+   end subroutine
+ 
+   subroutine bar
+     integer :: i
+     do i = 1, OLDSIZE
+       if (.not.flag .and. allocated (myarray(i)%i)) then
+         if (any (myarray(i)%i .ne. [1,2,3,4,5])) call abort
+       else
+         if (.not.flag) call abort
+       end if
+     end do
+   end subroutine
+ end program name
+ ! { dg-final { scan-tree-dump-times "__builtin_malloc" 11 "original" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } }
Index: gcc/testsuite/gfortran.dg/move_alloc_16.f90
===================================================================
*** gcc/testsuite/gfortran.dg/move_alloc_16.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/move_alloc_16.f90	(working copy)
***************
*** 0 ****
--- 1,44 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR67177 in which MOVE_ALLOC was not assigning the string
+ ! length for deferred length characters.
+ !
+ ! Contributed by <templed@tcd.ie>
+ !
+ program str
+   implicit none
+ 
+   type string
+     character(:), Allocatable :: text
+   end type string
+ 
+   type strings
+     type(string), allocatable, dimension(:) :: strlist
+   end type strings
+ 
+   type(strings) :: teststrs
+   type(string) :: tmpstr
+   integer :: strlen = 20
+ 
+   allocate (teststrs%strlist(1))
+   allocate (character(len=strlen) :: tmpstr%text)
+ 
+   allocate (character(len=strlen) :: teststrs%strlist(1)%text)
+ 
+ ! Full string reference was required because reallocation on assignment is
+ ! functioning when it should not if the lhs is a substring - PR67977
+   tmpstr%text(1:3) = 'foo'
+ 
+   if (.not.allocated (teststrs%strlist(1)%text)) call abort
+   if (len (tmpstr%text) .ne. strlen) call abort
+ 
+   call move_alloc(tmpstr%text,teststrs%strlist(1)%text)
+ 
+   if (.not.allocated (teststrs%strlist(1)%text)) call abort
+   if (len (teststrs%strlist(1)%text) .ne. strlen) call abort
+   if (trim (teststrs%strlist(1)%text(1:3)) .ne. 'foo') call abort
+ 
+ ! Clean up so that valgrind reports all allocated memory freed.
+   if (allocated (teststrs%strlist(1)%text)) deallocate (teststrs%strlist(1)%text)
+   if (allocated (teststrs%strlist)) deallocate (teststrs%strlist)
+ end program str
Index: gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_assignment_1.f90	(working copy)
***************
*** 0 ****
--- 1,22 ----
+ ! { dg-do run }
+ !
+ ! Checks the fix for PR67977 in which automatic reallocation on assignment
+ ! was performed when the lhs had a substring reference.
+ !
+ ! Contributed by Anton Shterenlikht  <mexas@bristol.ac.uk>
+ !
+   character(:), allocatable :: z
+   integer :: length
+   z = "cockatoo"
+   length = len (z)
+   z(:) = ''
+   if (len(z) .ne. length) call abort
+   if (trim (z) .ne. '') call abort
+   z(:3) = "foo"
+   if (len(z) .ne. length) call abort
+   if (trim (z) .ne. "foo") call abort
+   z(4:) = "__bar"
+   if (len(z) .ne. length) call abort
+   if (trim (z) .ne. "foo__bar") call abort
+   deallocate (z)
+ end

Re: [Patch, fortran] PR67177, 67977 and memory leaks in move_alloc

[Steve Kargl]

On Sat, Oct 17, 2015 at 09:49:45PM +0200, Paul Richard Thomas wrote:
> 
> I was moved by a report on clf of memory leaks in move_alloc to
> investigate the cause. This turned out to be trivial but led to the
> above PRs, which themselves were trivial. The result is the attached
> patch. I am aware that I have not investigated the further
> ramifications that I can imagine are there. Rather, I thought just to
> fix the reported problems.
> 
> It should be noted that there is no PR directly associated with the
> memory leaks. Since the standard does not require this, I did not
> think that it was worthwhile to raise a PR and then close it!
> 
> Bootstraps and regtests on FC21/x86_64 - OK for trunk? ... and 5.2
> after a decent interval?

OK.

-- 
steve

Re: [Patch, fortran] PR67177, 67977 and memory leaks in move_alloc

[Paul Richard Thomas]

Hi Steve,

Thanks - Committed as revision 228940.

I'll commit to 5 branch next Sunday.

Cheers

Paul


On 17 October 2015 at 22:51, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
> On Sat, Oct 17, 2015 at 09:49:45PM +0200, Paul Richard Thomas wrote:
>>
>> I was moved by a report on clf of memory leaks in move_alloc to
>> investigate the cause. This turned out to be trivial but led to the
>> above PRs, which themselves were trivial. The result is the attached
>> patch. I am aware that I have not investigated the further
>> ramifications that I can imagine are there. Rather, I thought just to
>> fix the reported problems.
>>
>> It should be noted that there is no PR directly associated with the
>> memory leaks. Since the standard does not require this, I did not
>> think that it was worthwhile to raise a PR and then close it!
>>
>> Bootstraps and regtests on FC21/x86_64 - OK for trunk? ... and 5.2
>> after a decent interval?
>
> OK.
>
> --
> steve



-- 
Outside of a dog, a book is a man's best friend. Inside of a dog it's
too dark to read.

Groucho Marx