re PR fortran/80477 ([OOP] Polymorphic function result generates memory leak)
authorPaul Thomas <pault@gcc.gnu.org>
Tue, 28 Aug 2018 11:35:52 +0000 (11:35 +0000)
committerPaul Thomas <pault@gcc.gnu.org>
Tue, 28 Aug 2018 11:35:52 +0000 (11:35 +0000)
2017-08-28  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/80477
* trans-expr.c (gfc_conv_procedure_call): Allocatable class
scalar results being passed to a derived type formal argument
are finalized if possible. Otherwise, rely on existing code for
deallocation. Make the deallocation of allocatable result
components conditional on finalization not taking place. Make
the freeing of data components after finalization conditional
on the data being NULL.
(gfc_trans_arrayfunc_assign): Change the gcc_assert to a
condition to return NULL_TREE.
(gfc_trans_assignment_1): If the assignment is class to class
and the rhs expression must be finalized but the assignment
is not marked as a polymorphic assignment, use the vptr copy
function instead of gfc_trans_scalar_assign.

PR fortran/86481
* trans-expr.c (gfc_conv_expr_reference): Do not add the post
block to the pre block if the expression is to be finalized.
* trans-stmt.c (gfc_trans_allocate): If the expr3 must be
finalized, load the post block into a finalization block and
add it right at the end of the allocation block.

2017-08-28  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/80477
* gfortran.dg/class_result_7.f90: New test.
* gfortran.dg/class_result_8.f90: New test.
* gfortran.dg/class_result_9.f90: New test.

PR fortran/86481
* gfortran.dg/allocate_with_source_25.f90: New test.

From-SVN: r263916

gcc/fortran/ChangeLog
gcc/fortran/trans-expr.c
gcc/fortran/trans-stmt.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_result_7.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_result_8.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/class_result_9.f90 [new file with mode: 0644]

index a3e9e39d7cd77208fb47306bc0e2cb1d2ded1f64..04598438aaededec6651157606153ad4e5823f1b 100644 (file)
@@ -1,3 +1,27 @@
+2017-08-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/80477
+       * trans-expr.c (gfc_conv_procedure_call): Allocatable class
+       scalar results being passed to a derived type formal argument
+       are finalized if possible. Otherwise, rely on existing code for
+       deallocation. Make the deallocation of allocatable result
+       components conditional on finalization not taking place. Make
+       the freeing of data components after finalization conditional
+       on the data being NULL.
+       (gfc_trans_arrayfunc_assign): Change the gcc_assert to a
+       condition to return NULL_TREE.
+       (gfc_trans_assignment_1): If the assignment is class to class
+       and the rhs expression must be finalized but the assignment
+       is not marked as a polymorphic assignment, use the vptr copy
+       function instead of gfc_trans_scalar_assign.
+
+       PR fortran/86481
+       * trans-expr.c (gfc_conv_expr_reference): Do not add the post
+       block to the pre block if the expression is to be finalized.
+       * trans-stmt.c (gfc_trans_allocate): If the expr3 must be
+       finalized, load the post block into a finalization block and
+       add it right at the end of the allocation block.
+
 2018-08-27  David Malcolm  <dmalcolm@redhat.com>
 
        PR 87091
index 54e318e21f753cac60858a5aab4b02fa6c9be4a8..56ce98c78c69283947fbde861510c639360ad200 100644 (file)
@@ -4886,6 +4886,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   for (arg = args, argc = 0; arg != NULL;
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
     {
+      bool finalized = false;
+
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
       parm_kind = MISSING;
@@ -5360,7 +5362,42 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                      && e->ts.type == BT_CLASS
                      && !CLASS_DATA (e)->attr.dimension
                      && !CLASS_DATA (e)->attr.codimension)
-                   parmse.expr = gfc_class_data_get (parmse.expr);
+                   {
+                     parmse.expr = gfc_class_data_get (parmse.expr);
+                     /* The result is a class temporary, whose _data component
+                        must be freed to avoid a memory leak.  */
+                     if (e->expr_type == EXPR_FUNCTION
+                         && CLASS_DATA (e)->attr.allocatable)
+                       {
+                         tree zero;
+
+                         gfc_expr *var;
+
+                         /* Borrow the function symbol to make a call to
+                            gfc_add_finalizer_call and then restore it.  */
+                         tmp = e->symtree->n.sym->backend_decl;
+                         e->symtree->n.sym->backend_decl
+                                       = TREE_OPERAND (parmse.expr, 0);
+                         e->symtree->n.sym->attr.flavor = FL_VARIABLE;
+                         var = gfc_lval_expr_from_sym (e->symtree->n.sym);
+                         finalized = gfc_add_finalizer_call (&parmse.post,
+                                                             var);
+                         gfc_free_expr (var);
+                         e->symtree->n.sym->backend_decl = tmp;
+                         e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+
+                         /* Then free the class _data.  */
+                         zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
+                         tmp = fold_build2_loc (input_location, NE_EXPR,
+                                                logical_type_node,
+                                                parmse.expr, zero);
+                         tmp = build3_v (COND_EXPR, tmp,
+                                         gfc_call_free (parmse.expr),
+                                         build_empty_stmt (input_location));
+                         gfc_add_expr_to_block (&parmse.post, tmp);
+                         gfc_add_modify (&parmse.post, parmse.expr, zero);
+                       }
+                   }
 
                  /* Wrap scalar variable in a descriptor. We need to convert
                     the address of a pointer back to the pointer itself before,
@@ -5687,9 +5724,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                tmp = build_fold_indirect_ref_loc (input_location, tmp);
            }
 
-         tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
-
-         gfc_prepend_expr_to_block (&post, tmp);
+         if (!finalized && !e->must_finalize)
+           {
+             if ((e->ts.type == BT_CLASS
+                  && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+                 || e->ts.type == BT_DERIVED)
+               tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
+                                                parm_rank);
+             else if (e->ts.type == BT_CLASS)
+               tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
+                                                tmp, parm_rank);
+             gfc_prepend_expr_to_block (&post, tmp);
+           }
         }
 
       /* Add argument checking of passing an unallocated/NULL actual to
@@ -6410,7 +6456,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          final_fndecl = gfc_class_vtab_final_get (se->expr);
          is_final = fold_build2_loc (input_location, NE_EXPR,
                                      logical_type_node,
-                                     final_fndecl,
+                                     final_fndecl,
                                      fold_convert (TREE_TYPE (final_fndecl),
                                                    null_pointer_node));
          final_fndecl = build_fold_indirect_ref_loc (input_location,
@@ -6420,28 +6466,43 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                     gfc_build_addr_expr (NULL, tmp),
                                     gfc_class_vtab_size_get (se->expr),
                                     boolean_false_node);
-         tmp = fold_build3_loc (input_location, COND_EXPR,
+         tmp = fold_build3_loc (input_location, COND_EXPR,
                                 void_type_node, is_final, tmp,
                                 build_empty_stmt (input_location));
 
          if (se->ss && se->ss->loop)
            {
-             gfc_add_expr_to_block (&se->ss->loop->post, tmp);
-             tmp = gfc_call_free (info->data);
+             gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
+             tmp = fold_build2_loc (input_location, NE_EXPR,
+                                    logical_type_node,
+                                    info->data,
+                                    fold_convert (TREE_TYPE (info->data),
+                                                   null_pointer_node));
+             tmp = fold_build3_loc (input_location, COND_EXPR,
+                                    void_type_node, tmp,
+                                    gfc_call_free (info->data),
+                                    build_empty_stmt (input_location));
              gfc_add_expr_to_block (&se->ss->loop->post, tmp);
            }
          else
            {
-             gfc_add_expr_to_block (&se->post, tmp);
-             tmp = gfc_class_data_get (se->expr);
-             tmp = gfc_call_free (tmp);
+             tree classdata;
+             gfc_prepend_expr_to_block (&se->post, tmp);
+             classdata = gfc_class_data_get (se->expr);
+             tmp = fold_build2_loc (input_location, NE_EXPR,
+                                    logical_type_node,
+                                    classdata,
+                                    fold_convert (TREE_TYPE (classdata),
+                                                   null_pointer_node));
+             tmp = fold_build3_loc (input_location, COND_EXPR,
+                                    void_type_node, tmp,
+                                    gfc_call_free (classdata),
+                                    build_empty_stmt (input_location));
              gfc_add_expr_to_block (&se->post, tmp);
            }
-
-no_finalization:
-         expr->must_finalize = 0;
        }
 
+no_finalization:
       gfc_add_block_to_block (&se->post, &post);
     }
 
@@ -8072,7 +8133,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       var = gfc_create_var (TREE_TYPE (se->expr), NULL);
       gfc_add_modify (&se->pre, var, se->expr);
     }
-  gfc_add_block_to_block (&se->pre, &se->post);
+
+  if (!expr->must_finalize)
+    gfc_add_block_to_block (&se->pre, &se->post);
 
   /* Take the address of that value.  */
   se->expr = gfc_build_addr_expr (NULL_TREE, var);
@@ -9262,10 +9325,12 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
   comp = gfc_get_proc_ptr_comp (expr2);
-  gcc_assert (expr2->value.function.isym
+
+  if (!(expr2->value.function.isym
              || (comp && comp->attr.dimension)
              || (!comp && gfc_return_by_reference (expr2->value.function.esym)
-                 && expr2->value.function.esym->result->attr.dimension));
+                 && expr2->value.function.esym->result->attr.dimension)))
+    return NULL;
 
   gfc_init_se (&se, NULL);
   gfc_start_block (&se.pre);
@@ -10238,6 +10303,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
        gfc_add_block_to_block (&loop.post, &rse.post);
     }
 
+  tmp = NULL_TREE;
+
   if (is_poly_assign)
     tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
                                  use_vptr_copy || (lhs_attr.allocatable
@@ -10266,13 +10333,35 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
       tmp = gfc_conv_intrinsic_subroutine (&code);
     }
-  else
+  else if (!is_poly_assign && expr2->must_finalize
+          && expr1->ts.type == BT_CLASS
+          && expr2->ts.type == BT_CLASS)
+    {
+      /* This case comes about when the scalarizer provides array element
+        references. Use the vptr copy function, since this does a deep
+        copy of allocatable components, without which the finalizer call */
+      tmp = gfc_get_vptr_from_expr (rse.expr);
+      if (tmp != NULL_TREE)
+       {
+         tree fcn = gfc_vptr_copy_get (tmp);
+         if (POINTER_TYPE_P (TREE_TYPE (fcn)))
+           fcn = build_fold_indirect_ref_loc (input_location, fcn);
+         tmp = build_call_expr_loc (input_location,
+                                    fcn, 2,
+                                    gfc_build_addr_expr (NULL, rse.expr),
+                                    gfc_build_addr_expr (NULL, lse.expr));
+       }
+    }
+
+  /* If nothing else works, do it the old fashioned way!  */
+  if (tmp == NULL_TREE)
     tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
                                   gfc_expr_is_variable (expr2)
                                   || scalar_to_array
                                   || expr2->expr_type == EXPR_ARRAY,
                                   !(l_is_temp || init_flag) && dealloc,
                                   expr1->symtree->n.sym->attr.codimension);
+
   /* Add the pre blocks to the body.  */
   gfc_add_block_to_block (&body, &rse.pre);
   gfc_add_block_to_block (&body, &lse.pre);
index cc1a42943277328efbcfc109d6582c186bb25c14..795d3cc0a13c2033a3ca2e2a5e5eb971179d568d 100644 (file)
@@ -5783,6 +5783,7 @@ gfc_trans_allocate (gfc_code * code)
   enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
   stmtblock_t block;
   stmtblock_t post;
+  stmtblock_t final_block;
   tree nelems;
   bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
   bool needs_caf_sync, caf_refs_comp;
@@ -5801,6 +5802,7 @@ gfc_trans_allocate (gfc_code * code)
 
   gfc_init_block (&block);
   gfc_init_block (&post);
+  gfc_init_block (&final_block);
 
   /* STAT= (and maybe ERRMSG=) is present.  */
   if (code->expr1)
@@ -5842,6 +5844,11 @@ gfc_trans_allocate (gfc_code * code)
 
       is_coarray = gfc_is_coarray (code->expr3);
 
+      if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
+         && (gfc_is_class_array_function (code->expr3)
+             || gfc_is_alloc_class_scalar_function (code->expr3)))
+       code->expr3->must_finalize = 1;
+
       /* Figure whether we need the vtab from expr3.  */
       for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
           al = al->next)
@@ -5914,7 +5921,10 @@ gfc_trans_allocate (gfc_code * code)
          temp_obj_created = temp_var_needed = !VAR_P (se.expr);
        }
       gfc_add_block_to_block (&block, &se.pre);
-      gfc_add_block_to_block (&post, &se.post);
+      if (code->expr3->must_finalize)
+       gfc_add_block_to_block (&final_block, &se.post);
+      else
+       gfc_add_block_to_block (&post, &se.post);
 
       /* Special case when string in expr3 is zero.  */
       if (code->expr3->ts.type == BT_CHARACTER
@@ -6743,6 +6753,8 @@ gfc_trans_allocate (gfc_code * code)
 
   gfc_add_block_to_block (&block, &se.post);
   gfc_add_block_to_block (&block, &post);
+  if (code->expr3 && code->expr3->must_finalize)
+    gfc_add_block_to_block (&block, &final_block);
 
   return gfc_finish_block (&block);
 }
index c62104902f5b8fae7b452ae8bdcc67e5590b522e..64638c544f125a28a7921f42b00e9ca91dbcc624 100644 (file)
@@ -1,3 +1,13 @@
+2017-08-28  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/80477
+       * gfortran.dg/class_result_7.f90: New test.
+       * gfortran.dg/class_result_8.f90: New test.
+       * gfortran.dg/class_result_9.f90: New test.
+
+       PR fortran/86481
+       * gfortran.dg/allocate_with_source_25.f90: New test.
+
 2018-08-28  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/87099
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
new file mode 100644 (file)
index 0000000..92dc507
--- /dev/null
@@ -0,0 +1,71 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+!  Test the fix for PR86481
+!
+! Contributed by Rich Townsend  <townsend@astro.wisc.edu>
+!
+program simple_leak
+
+  implicit none
+
+  type, abstract :: foo_t
+  end type foo_t
+
+  type, extends(foo_t) :: foo_a_t
+     real(8), allocatable :: a(:)
+  end type foo_a_t
+
+  type, extends(foo_t) ::  bar_t
+     class(foo_t), allocatable :: f
+  end type bar_t
+
+  integer, parameter :: N = 2
+  integer, parameter :: D = 3
+
+  type(bar_t) :: b(N)
+  integer     :: i
+
+  do i = 1, N
+     b(i) = func_bar(D)
+  end do
+
+  do i = 1, N
+     deallocate (b(i)%f)
+  end do
+
+contains
+
+  function func_bar (D) result (b)
+
+    integer, intent(in) :: D
+    type(bar_t)         :: b
+
+    allocate(b%f, SOURCE=func_foo(D))
+
+  end function func_bar
+
+  !****
+
+  function func_foo (D) result (f)
+
+    integer, intent(in)       :: D
+    class(foo_t), allocatable :: f
+
+    allocate(f, SOURCE=func_foo_a(D)) ! Lose one of these for each allocation
+
+  end function func_foo
+
+  !****
+
+  function func_foo_a (D) result (f)
+
+    integer, intent(in) :: D
+    type(foo_a_t)       :: f
+
+    allocate(f%a(D))  ! Lose one of these for each allocation => N*D*elem_size(f%a)
+
+  end function func_foo_a
+
+end program simple_leak
+! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_result_7.f90 b/gcc/testsuite/gfortran.dg/class_result_7.f90
new file mode 100644 (file)
index 0000000..066da54
--- /dev/null
@@ -0,0 +1,36 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+!  Test the fix for PR80477
+!
+! Contributed by Stefano Zaghi  <stefano.zaghi@cnr.it>
+!
+module a_type_m
+   implicit none
+   type :: a_type_t
+      real :: x
+   endtype
+contains
+   subroutine assign_a_type(lhs, rhs)
+      type(a_type_t), intent(inout) :: lhs
+      type(a_type_t), intent(in)    :: rhs
+      lhs%x = rhs%x
+   end subroutine
+
+   function add_a_type(lhs, rhs) result( res )
+      type(a_type_t), intent(in)  :: lhs
+      type(a_type_t), intent(in)  :: rhs
+      class(a_type_t), allocatable :: res
+      allocate (a_type_t :: res)
+      res%x = lhs%x + rhs%x
+   end function
+end module
+
+program polymorphic_operators_memory_leaks
+   use a_type_m
+   implicit none
+   type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+   call assign_a_type (a, add_a_type(a,b))              ! generated a memory leak
+end
+! { dg-final { scan-tree-dump-times "builtin_free" 1 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_result_8.f90 b/gcc/testsuite/gfortran.dg/class_result_8.f90
new file mode 100644 (file)
index 0000000..573dd44
--- /dev/null
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+!  Test the fix for the array version of PR80477
+!
+! Contributed by Stefano Zaghi  <stefano.zaghi@cnr.it>
+!
+module a_type_m
+   implicit none
+   type :: a_type_t
+      real :: x
+      real, allocatable :: y(:)
+   endtype
+contains
+   subroutine assign_a_type(lhs, rhs)
+      type(a_type_t), intent(inout) :: lhs
+      type(a_type_t), intent(in)    :: rhs(:)
+      lhs%x = rhs(1)%x + rhs(2)%x
+   end subroutine
+
+   function add_a_type(lhs, rhs) result( res )
+      type(a_type_t), intent(in)  :: lhs
+      type(a_type_t), intent(in)  :: rhs
+      class(a_type_t), allocatable :: res(:)
+      allocate (a_type_t :: res(2))
+      allocate (res(1)%y(1))
+      allocate (res(2)%y(1))
+      res(1)%x = lhs%x
+      res(2)%x = rhs%x
+   end function
+end module
+
+program polymorphic_operators_memory_leaks
+   use a_type_m
+   implicit none
+   type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+   call assign_a_type (a, add_a_type(a,b))
+   print *, a%x
+end
+! { dg-final { scan-tree-dump-times "builtin_free" 6 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/class_result_9.f90 b/gcc/testsuite/gfortran.dg/class_result_9.f90
new file mode 100644 (file)
index 0000000..10bc139
--- /dev/null
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+!  Test the fix for an additional bug found while fixing PR80477
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module a_type_m
+   implicit none
+   type :: a_type_t
+      real :: x
+      real, allocatable :: y(:)
+   endtype
+contains
+   subroutine assign_a_type(lhs, rhs)
+      type(a_type_t), intent(inout) :: lhs
+      type(a_type_t), intent(in)    :: rhs(:)
+      lhs%x = rhs(1)%x + rhs(2)%x
+      lhs%y = rhs(1)%y + rhs(2)%y
+   end subroutine
+
+   function add_a_type(lhs, rhs) result( res )
+      type(a_type_t), intent(in)  :: lhs
+      type(a_type_t), intent(in)  :: rhs
+      class(a_type_t), allocatable :: res(:)
+      allocate (a_type_t :: res(2))
+      allocate (res(1)%y(1), source = [10.0])
+      allocate (res(2)%y(1), source = [20.0])
+      res(1)%x = lhs%x + rhs%x
+      res(2)%x = rhs%x + rhs%x
+   end function
+end module
+
+program polymorphic_operators_memory_leaks
+    use a_type_m
+    implicit none
+    type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2)
+    class(a_type_t), allocatable :: res(:)
+
+    res = add_a_type(a,b)        ! Remarkably, this ICEd - found while debugging the PR.
+    call assign_a_type (a, res)
+    if (int (res(1)%x + res(2)%x) .ne. int (a%x)) stop 1
+    if (int (sum (res(1)%y + res(2)%y)) .ne. int (sum (a%y))) stop 1
+    deallocate (a%y)
+    deallocate (res)
+end